home *** CD-ROM | disk | FTP | other *** search
/ PC Open 100 / PC Open 100 CD 1.bin / CD1 / INTERNET / EMAIL / pop file / setup.exe / Classifier / Bayes.pm next >
Encoding:
Perl POD Document  |  2004-03-16  |  122.3 KB  |  3,497 lines
  1. # POPFILE LOADABLE MODULE
  2. package Classifier::Bayes;
  3.  
  4. use POPFile::Module;
  5. @ISA = ("POPFile::Module");
  6.  
  7. # ---------------------------------------------------------------------------------------------
  8. #
  9. # Bayes.pm --- Naive Bayes text classifier
  10. #
  11. # Copyright (c) 2001-2003 John Graham-Cumming
  12. #
  13. #   This file is part of POPFile
  14. #
  15. #   POPFile is free software; you can redistribute it and/or modify
  16. #   it under the terms of the GNU General Public License as published by
  17. #   the Free Software Foundation; either version 2 of the License, or
  18. #   (at your option) any later version.
  19. #
  20. #   POPFile is distributed in the hope that it will be useful,
  21. #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  22. #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23. #   GNU General Public License for more details.
  24. #
  25. #   You should have received a copy of the GNU General Public License
  26. #   along with POPFile; if not, write to the Free Software
  27. #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  28. #
  29. #   Modified by              Sam Schinke    (sschinke@users.sourceforge.net)
  30. #   Merged with db code from Scott Leighton (helphand@users.sourceforge.net)
  31. #
  32. # ---------------------------------------------------------------------------------------------
  33.  
  34. use strict;
  35. use warnings;
  36. use locale;
  37. use Classifier::MailParse;
  38. use IO::Handle;
  39. use DBI;
  40. use Digest::MD5 qw( md5_hex );
  41.  
  42. # This is used to get the hostname of the current machine
  43. # in a cross platform way
  44.  
  45. use Sys::Hostname;
  46.  
  47. # A handy variable containing the value of an EOL for networks
  48.  
  49. my $eol = "\015\012";
  50.  
  51. # Korean characters definition
  52.  
  53. my $ksc5601_sym = '(?:[\xA1-\xAC][\xA1-\xFE])';
  54. my $ksc5601_han = '(?:[\xB0-\xC8][\xA1-\xFE])';
  55. my $ksc5601_hanja  = '(?:[\xCA-\xFD][\xA1-\xFE])';
  56. my $ksc5601 = "(?:$ksc5601_sym|$ksc5601_han|$ksc5601_hanja)";
  57.  
  58. my $eksc = "(?:$ksc5601|[\x81-\xC6][\x41-\xFE])"; #extended ksc
  59.  
  60. #----------------------------------------------------------------------------
  61. # new
  62. #
  63. #   Class new() function
  64. #----------------------------------------------------------------------------
  65. sub new
  66. {
  67.     my $type = shift;
  68.     my $self = POPFile::Module->new();
  69.  
  70.     # Set this to 1 to get scores for individual words in message detail
  71.  
  72.     $self->{wordscores__}        = 0;
  73.  
  74.     # Choice for the format of the "word matrix" display.
  75.  
  76.     $self->{wmformat__}          = '';
  77.  
  78.     # Just our hostname
  79.  
  80.     $self->{hostname__}        = '';
  81.  
  82.     # File Handle for DBI database
  83.  
  84.     $self->{db__}                = {};
  85.  
  86.     # To save time we also 'prepare' some commonly used SQL statements and cache
  87.     # them here, see the function db_connect__ for details
  88.  
  89.     $self->{db_get_buckets__} = 0;
  90.     $self->{db_get_wordid__} = 0;
  91.     $self->{db_get_word_count__} = 0;
  92.     $self->{db_put_word_count__} = 0;
  93.     $self->{db_get_bucket_unique_counts__} = 0;
  94.     $self->{db_get_unique_word_count__} = 0;
  95.     $self->{db_get_bucket_word_counts__} = 0;
  96.     $self->{db_get_full_total__} = 0;
  97.     $self->{db_get_bucket_parameter__} = 0;
  98.     $self->{db_set_bucket_parameter__} = 0;
  99.     $self->{db_get_bucket_parameter_default__} = 0;
  100.     $self->{db_get_buckets_with_magnets__} = 0;
  101.     $self->{db_delete_zero_words__} = 0;
  102.  
  103.     # Caches the name of each bucket and relates it to both the bucket ID in the
  104.     # database and whether it is pseudo or not
  105.     #
  106.     # Subkeys used are:
  107.     #
  108.     # id     The bucket ID in the database
  109.     # pseudo 1 if this is a pseudo bucket
  110.  
  111.     $self->{db_bucketid__}       = {};
  112.  
  113.     # Caches the IDs that map to parameter types
  114.  
  115.     $self->{db_parameterid__}    = {};
  116.  
  117.     # Caches looked up parameter values on a per bucket basis
  118.  
  119.     $self->{db_parameters__}     = {};
  120.  
  121.     # Used to parse mail messages
  122.     $self->{parser__}            = new Classifier::MailParse;
  123.  
  124.     # The possible colors for buckets
  125.     $self->{possible_colors__} = [ 'red',       'green',      'blue',       'brown', # PROFILE BLOCK START
  126.                                    'orange',    'purple',     'magenta',    'gray',
  127.                                    'plum',      'silver',     'pink',       'lightgreen',
  128.                                    'lightblue', 'lightcyan',  'lightcoral', 'lightsalmon',
  129.                                    'lightgrey', 'darkorange', 'darkcyan',   'feldspar' ]; # PROFILE BLOCK STOP
  130.  
  131.     # Precomputed per bucket probabilities
  132.     $self->{bucket_start__}      = {};
  133.  
  134.     # A very unlikely word
  135.     $self->{not_likely__}        = {};
  136.  
  137.     # The expected corpus version
  138.     #
  139.     # DEPRECATED  This is only used when upgrading old flat file corpus files
  140.     #             to the database
  141.     $self->{corpus_version__}    = 1;
  142.  
  143.     # The unclassified cutoff this value means that the top probabilily must be n times greater than the
  144.     # second probability, default is 100 times more likely
  145.     $self->{unclassified__}      = log(100);
  146.  
  147.     # Used to tell the caller whether a magnet was used in the last
  148.     # mail classification
  149.     $self->{magnet_used__}       = 0;
  150.     $self->{magnet_detail__}     = '';
  151.  
  152.     # This maps session keys (long strings) to user ids.  If there's an entry here then the session key
  153.     # is valid and can be used in the POPFile API.   See the methods get_session_key and release_session_key
  154.     # for details
  155.  
  156.     $self->{api_sessions__}      = {};
  157.  
  158.     # Must call bless before attempting to call any methods
  159.  
  160.     bless $self, $type;
  161.  
  162.     $self->name( 'bayes' );
  163.  
  164.     return $self;
  165. }
  166.  
  167. # ---------------------------------------------------------------------------------------------
  168. #
  169. # forked
  170. #
  171. # This is called inside a child process that has just forked, since the child needs access
  172. # to the database we open it
  173. #
  174. # ---------------------------------------------------------------------------------------------
  175. sub forked
  176. {
  177.     my ( $self ) = @_;
  178.  
  179.     $self->db_connect__();
  180. }
  181.  
  182. # ---------------------------------------------------------------------------------------------
  183. #
  184. # initialize
  185. #
  186. # Called to set up the Bayes module's parameters
  187. #
  188. # ---------------------------------------------------------------------------------------------
  189. sub initialize
  190. {
  191.     my ( $self ) = @_;
  192.  
  193.     # This is the name for the database
  194.  
  195.     $self->config_( 'database', 'popfile.db' );
  196.  
  197.     # This is the 'connect' string used by DBI to connect to the database, if
  198.     # you decide to change from using SQLite to some other database (e.g. MySQL,
  199.     # Oracle, ... ) this *should* be all you need to change.  The additional
  200.     # parameters user and auth are needed for some databases.
  201.     #
  202.     # Note that the dbconnect string will be interpolated before being passed
  203.     # to DBI and the variable $dbname can be used within it and it resolves to
  204.     # the full path to the database named in the database parameter above.
  205.  
  206.     $self->config_( 'dbconnect', 'dbi:SQLite:dbname=$dbname' );
  207.     $self->config_( 'dbuser',   '' );
  208.     $self->config_( 'dbauth',   '' );
  209.  
  210.     # No default unclassified weight is the number of times more sure POPFile
  211.     # must be of the top class vs the second class, default is 100 times more
  212.  
  213.     $self->config_( 'unclassified_weight', 100 );
  214.  
  215.     # The corpus is kept in the 'corpus' subfolder of POPFile
  216.     #
  217.     # DEPRECATED This is only used to find an old corpus that might need to
  218.     # be upgraded
  219.  
  220.     $self->config_( 'corpus', 'corpus' );
  221.  
  222.     # The characters that appear before and after a subject modification
  223.  
  224.     $self->config_( 'subject_mod_left',  '[' );
  225.     $self->config_( 'subject_mod_right', ']' );
  226.  
  227.     # Get the hostname for use in the X-POPFile-Link header
  228.  
  229.     $self->{hostname__} = hostname;
  230.  
  231.     # Allow the user to override the hostname
  232.  
  233.     $self->config_( 'hostname', $self->{hostname__} );
  234.  
  235.     return 1;
  236. }
  237.  
  238. # ---------------------------------------------------------------------------------------------
  239. #
  240. # start
  241. #
  242. # Called to start the Bayes module running
  243. #
  244. # ---------------------------------------------------------------------------------------------
  245. sub start
  246. {
  247.     my ( $self ) = @_;
  248.  
  249.     # Pass in the current interface language for language specific parsing
  250.  
  251.     $self->{parser__}->{lang__}  = $self->module_config_( 'html', 'language' );
  252.     $self->{unclassified__} = log( $self->config_( 'unclassified_weight' ) );
  253.  
  254.     if ( !$self->db_connect__() ) {
  255.         return 0;
  256.     }
  257.  
  258.     $self->upgrade_predatabase_data__();
  259.  
  260.     return 1;
  261. }
  262.  
  263. # ---------------------------------------------------------------------------------------------
  264. #
  265. # stop
  266. #
  267. # Called when POPFile is terminating
  268. #
  269. # ---------------------------------------------------------------------------------------------
  270. sub stop
  271. {
  272.     my ( $self ) = @_;
  273.  
  274.     $self->db_disconnect__();
  275. }
  276.  
  277. # ---------------------------------------------------------------------------------------------
  278. #
  279. # classified
  280. #
  281. # Called to inform the module about a classification event
  282. #
  283. # There is no return value from this method
  284. #
  285. # ---------------------------------------------------------------------------------------------
  286. sub classified
  287. {
  288.     my ( $self, $session, $class ) = @_;
  289.  
  290.     $self->set_bucket_parameter( $session, $class, 'count',             # PROFILE BLOCK START
  291.         $self->get_bucket_parameter( $session, $class, 'count' ) + 1 ); # PROFILE BLOCK STOP
  292. }
  293.  
  294. # ---------------------------------------------------------------------------------------------
  295. #
  296. # get_color
  297. #
  298. # Retrieves the color for a specific word, color is the most likely bucket
  299. #
  300. # $session  Session key returned by get_session_key
  301. # $word     Word to get the color of
  302. #
  303. # ---------------------------------------------------------------------------------------------
  304. sub get_color
  305. {
  306.     my ( $self, $session, $word ) = @_;
  307.  
  308.     my $max   = -10000;
  309.     my $color = 'black';
  310.  
  311.     for my $bucket ($self->get_buckets( $session )) {
  312.         my $prob = $self->get_value_( $session, $bucket, $word );
  313.  
  314.         if ( $prob != 0 )  {
  315.             if ( $prob > $max )  {
  316.                 $max   = $prob;
  317.                 $color = $self->get_bucket_parameter( $session, $bucket, 'color' );
  318.             }
  319.         }
  320.     }
  321.  
  322.     return $color;
  323. }
  324.  
  325. # ---------------------------------------------------------------------------------------------
  326. #
  327. # get_not_likely_
  328. #
  329. # Returns the probability of a word that doesn't appear
  330. #
  331. # ---------------------------------------------------------------------------------------------
  332. sub get_not_likely_
  333. {
  334.     my ( $self, $session ) = @_;
  335.  
  336.     my $userid = $self->valid_session_key__( $session );
  337.     return undef if ( !defined( $userid ) );
  338.  
  339.     return $self->{not_likely__}{$userid};
  340. }
  341.  
  342. # ---------------------------------------------------------------------------------------------
  343. #
  344. # get_value_
  345. #
  346. # Returns the value for a specific word in a bucket.  The word is converted to the log value
  347. # of the probability before return to get the raw value just hit the hash directly or call
  348. # get_base_value_
  349. #
  350. # ---------------------------------------------------------------------------------------------
  351. sub get_value_
  352. {
  353.     my ( $self, $session, $bucket, $word ) = @_;
  354.  
  355.     my $value = $self->db_get_word_count__( $session, $bucket, $word );
  356.  
  357.     if ( defined( $value ) && ( $value > 0 ) ) {
  358.  
  359.         # Profiling notes:
  360.         #
  361.         # I tried caching the log of the total value and then doing
  362.         # log( $value ) - $cached and this turned out to be
  363.         # much slower than this single log with a division in it
  364.  
  365.         return log( $value / $self->get_bucket_word_count( $session, $bucket ) );
  366.     } else {
  367.         return 0;
  368.     }
  369. }
  370.  
  371. sub get_base_value_
  372. {
  373.     my ( $self, $session, $bucket, $word ) = @_;
  374.  
  375.     my $value = $self->db_get_word_count__( $session, $bucket, $word );
  376.  
  377.     if ( defined( $value ) ) {
  378.         return $value;
  379.     } else {
  380.         return 0;
  381.     }
  382. }
  383.  
  384. # ---------------------------------------------------------------------------------------------
  385. #
  386. # set_value_
  387. #
  388. # Sets the value for a word in a bucket and updates the total word counts for the bucket
  389. # and globally
  390. #
  391. # ---------------------------------------------------------------------------------------------
  392. sub set_value_
  393. {
  394.     my ( $self, $session, $bucket, $word, $value ) = @_;
  395.  
  396.     if ( $self->db_put_word_count__( $session, $bucket, $word, $value ) == 1 ) {
  397.  
  398.         # If we set the word count to zero then clean it up by deleting the
  399.         # entry
  400.  
  401.         my $userid = $self->valid_session_key__( $session );
  402.         my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  403.         $self->{db_delete_zero_words__}->execute( $bucketid );
  404.  
  405.         return 1;
  406.     } else {
  407.         return 0;
  408.     }
  409. }
  410.  
  411. # ---------------------------------------------------------------------------------------------
  412. #
  413. # get_sort_value_ behaves the same as get_value_, except that it returns not_likely__ rather
  414. # than 0 if the word is not found.  This makes its result more suitable as a sort key for bucket
  415. # ranking.
  416. #
  417. # ---------------------------------------------------------------------------------------------
  418. sub get_sort_value_
  419. {
  420.     my ( $self, $session, $bucket, $word ) = @_;
  421.  
  422.     my $v = $self->get_value_( $session, $bucket, $word );
  423.  
  424.     if ( $v == 0 ) {
  425.  
  426.         my $userid = $self->valid_session_key__( $session );
  427.         return undef if ( !defined( $userid ) );
  428.  
  429.         return $self->{not_likely__}{$userid};
  430.     } else {
  431.         return $v;
  432.     }
  433. }
  434.  
  435. # ---------------------------------------------------------------------------------------------
  436. #
  437. # update_constants__
  438. #
  439. # Updates not_likely and bucket_start
  440. #
  441. # ---------------------------------------------------------------------------------------------
  442. sub update_constants__
  443. {
  444.     my ( $self, $session ) = @_;
  445.  
  446.     my $wc = $self->get_word_count( $session );
  447.  
  448.     my $userid = $self->valid_session_key__( $session );
  449.     return undef if ( !defined( $userid ) );
  450.  
  451.     if ( $wc > 0 )  {
  452.         $self->{not_likely__}{$userid} = -log( 10 * $wc );
  453.  
  454.         foreach my $bucket ($self->get_buckets( $session )) {
  455.             my $total = $self->get_bucket_word_count( $session, $bucket );
  456.  
  457.             if ( $total != 0 ) {
  458.                 $self->{bucket_start__}{$userid}{$bucket} = log( $total / $wc );
  459.             } else {
  460.                 $self->{bucket_start__}{$userid}{$bucket} = 0;
  461.             }
  462.         }
  463.     } else {
  464.         $self->{not_likely__}{$userid} = 0;
  465.     }
  466. }
  467.  
  468. # ---------------------------------------------------------------------------------------------
  469. #
  470. # parse_with_kakasi__
  471. #
  472. # Parse Japanese mail message with Kakasi
  473. #
  474. # Japanese needs to be parsed by language processing filter, "Kakasi"
  475. # before it is passed to Bayes classifier because words are not splitted
  476. # by spaces.
  477. #
  478. # $file           The file to parse
  479. #
  480. # ---------------------------------------------------------------------------------------------
  481. sub parse_with_kakasi__
  482. {
  483.     my ( $self, $file, $dcount, $mcount ) = @_;
  484.  
  485.     # This is used for Japanese support
  486.     require Encode;
  487.  
  488.     # This is used to parse Japanese
  489.     require Text::Kakasi;
  490.  
  491.     my $temp_file  = $self->get_user_path_( $self->global_config_( 'msgdir' ) . "kakasi$dcount" . "=$mcount.msg" );
  492.  
  493.     # Split Japanese email body into words using Kakasi Wakachigaki
  494.     # mode(-w is passed to Kakasi as argument). The most common charset of
  495.     # Japanese email is ISO-2022-JP, alias is jis, so -ijis and -ojis
  496.     # are passed to tell Kakasi the input charset and the output charset
  497.     # explicitly.
  498.     #
  499.     # After Kakasi processing, Encode::from_to is used to convert into UTF-8.
  500.     #
  501.     # Japanese email charset is assumed to be ISO-2022-JP. Needs to expand for
  502.     # other possible charset, such as Shift_JIS, EUC-JP, UTF-8.
  503.  
  504.     Text::Kakasi::getopt_argv("kakasi", "-w -ijis -ojis");
  505.     open KAKASI_IN, "<$file";
  506.     open KAKASI_OUT, ">$temp_file";
  507.  
  508.     while( <KAKASI_IN> ){
  509.         my $kakasi_out;
  510.  
  511.     $kakasi_out = Text::Kakasi::do_kakasi($_);
  512.         Encode::from_to($kakasi_out, "iso-2022-jp", "euc-jp");
  513.         print KAKASI_OUT $kakasi_out;
  514.     }
  515.  
  516.     close KAKASI_OUT;
  517.     close KAKASI_IN;
  518.     Text::Kakasi::close_kanwadict();
  519.     unlink( $file );
  520.     rename( $temp_file, $file );
  521. }
  522.  
  523. # ---------------------------------------------------------------------------------------------
  524. #
  525. # db_connect__
  526. #
  527. # Connects to the POPFile database and returns 1 if successful
  528. #
  529. # ---------------------------------------------------------------------------------------------
  530. sub db_connect__
  531. {
  532.     my ( $self ) = @_;
  533.  
  534.     # Connect to the database, note that the database must exist for this to work,
  535.     # to make this easy for people POPFile we will create the database automatically
  536.     # here using the file 'popfile.sql' which should be located in the same directory
  537.     # the Classifier/Bayes.pm module
  538.  
  539.     my $dbname = $self->get_user_path_( $self->config_( 'database' ) );
  540.     my $dbpresent = ( -e $dbname ) || 0;
  541.  
  542.     # Now perform the connect, note that this is database independent at this point, the
  543.     # actual database that we connect to is defined by the dbconnect parameter.
  544.  
  545.     my $dbconnect = $self->config_( 'dbconnect' );
  546.     $dbconnect =~ s/\$dbname/$dbname/g;
  547.  
  548.     $self->log_( "Attempting to connect to $dbconnect ($dbpresent)" );
  549.  
  550.     $self->{db__} = DBI->connect( $dbconnect,                    # PROFILE BLOCK START
  551.                                   $self->config_( 'dbuser' ),
  552.                                   $self->config_( 'dbauth' ) );  # PROFILE BLOCK STOP
  553.  
  554.     if ( !defined( $self->{db__} ) ) {
  555.         $self->log_( "Failed to connect to database and got error $DBI::errstr" );
  556.         return 0;
  557.     }
  558.  
  559.     if ( !$dbpresent ) {
  560.         if ( -e $self->get_root_path_( 'Classifier/popfile.sql' ) ) {
  561.             my $schema = '';
  562.  
  563.             $self->log_( "Creating database schema" );
  564.  
  565.             open SCHEMA, '<' . $self->get_root_path_( 'Classifier/popfile.sql' );
  566.             while ( <SCHEMA> ) {
  567.                 next if ( /^--/ );
  568.                 next if ( !/[a-z;]/ );
  569.                 s/--.*$//;
  570.  
  571.                 # If the line begins 'alter' and we are doing SQLite then ignore
  572.                 # the line
  573.  
  574.                 if ( ( $dbconnect =~ /sqlite/i ) && ( /^alter/i ) ) {
  575.             next;
  576.             }
  577.  
  578.                 $schema .= $_;
  579.  
  580.                 if ( ( /end;/ ) || ( /\);/ ) ) {
  581.                     $self->{db__}->do( $schema );
  582.                     $schema = '';
  583.         }
  584.         }
  585.             close SCHEMA;
  586.     } else {
  587.             $self->log_( "Can't find the database schema" );
  588.             return 0;
  589.     }
  590.     }
  591.  
  592.     # Now prepare common SQL statements for use, as a matter of convention the
  593.     # parameters to each statement always appear in the following order:
  594.     #
  595.     # user
  596.     # bucket
  597.     # word
  598.     # parameter
  599.  
  600.     $self->{db_get_buckets__} = $self->{db__}->prepare(                                 # PROFILE BLOCK START
  601.             'select name, id, pseudo from buckets
  602.                   where buckets.userid = ?;' );                                         # PROFILE BLOCK STOP
  603.  
  604.     $self->{db_get_wordid__} = $self->{db__}->prepare(                                  # PROFILE BLOCK START
  605.          'select id from words
  606.                   where words.word = ? limit 1;' );                                     # PROFILE BLOCK STOP
  607.  
  608.     $self->{db_get_userid__} = $self->{db__}->prepare(                                  # PROFILE BLOCK START
  609.              'select id from users where name = ?
  610.                                      and password = ? limit 1;' );                      # PROFILE BLOCK STOP
  611.  
  612.     $self->{db_get_word_count__} = $self->{db__}->prepare(                              # PROFILE BLOCK START
  613.          'select matrix.times from matrix
  614.                   where matrix.bucketid = ? and
  615.                         matrix.wordid = ? limit 1;' );                                  # PROFILE BLOCK STOP
  616.  
  617.     $self->{db_put_word_count__} = $self->{db__}->prepare(                              # PROFILE BLOCK START
  618.        'replace into matrix ( bucketid, wordid, times ) values ( ?, ?, ? );' );     # PROFILE BLOCK STOP
  619.  
  620.     $self->{db_get_bucket_unique_counts__} = $self->{db__}->prepare(                    # PROFILE BLOCK START
  621.          'select count(matrix.wordid), buckets.name from matrix, buckets
  622.                   where buckets.userid = ?
  623.                     and matrix.bucketid = buckets.id
  624.                   group by buckets.name;' );                                            # PROFILE BLOCK STOP
  625.  
  626.     $self->{db_get_bucket_word_counts__} = $self->{db__}->prepare(                      # PROFILE BLOCK START
  627.          'select sum(matrix.times), buckets.name from matrix, buckets
  628.                   where matrix.bucketid = buckets.id
  629.                     and buckets.userid = ?
  630.                     group by buckets.name;' );                                          # PROFILE BLOCK STOP
  631.  
  632.     $self->{db_get_unique_word_count__} = $self->{db__}->prepare(                       # PROFILE BLOCK START
  633.          'select count(matrix.wordid) from matrix, buckets
  634.                   where matrix.bucketid = buckets.id and
  635.                         buckets.userid = ?;' );                                         # PROFILE BLOCK STOP
  636.  
  637.     $self->{db_get_full_total__} = $self->{db__}->prepare(                              # PROFILE BLOCK START
  638.          'select sum(matrix.times) from matrix, buckets
  639.                   where buckets.userid = ? and
  640.                         matrix.bucketid = buckets.id;' );                               # PROFILE BLOCK STOP
  641.  
  642.     $self->{db_get_bucket_parameter__} = $self->{db__}->prepare(                        # PROFILE BLOCK START
  643.              'select bucket_params.val from bucket_params
  644.                   where bucket_params.bucketid = ? and
  645.                         bucket_params.btid = ?;' );                                     # PROFILE BLOCK STOP
  646.  
  647.     $self->{db_set_bucket_parameter__} = $self->{db__}->prepare(                        # PROFILE BLOCK START
  648.        'replace into bucket_params ( bucketid, btid, val ) values ( ?, ?, ? );' );  # PROFILE BLOCK STOP
  649.                                              
  650.     $self->{db_get_bucket_parameter_default__} = $self->{db__}->prepare(                # PROFILE BLOCK START
  651.              'select bucket_template.def from bucket_template
  652.                   where bucket_template.id = ?;' );                                     # PROFILE BLOCK STOP
  653.  
  654.     $self->{db_get_buckets_with_magnets__} = $self->{db__}->prepare(                    # PROFILE BLOCK START
  655.              'select buckets.name from buckets, magnets
  656.                   where buckets.userid = ? and
  657.                         magnets.bucketid = buckets.id group by buckets.name order by buckets.name;' );
  658.                                                                                         # PROFILE BLOCK STOP
  659.     $self->{db_delete_zero_words__} = $self->{db__}->prepare(                           # PROFILE BLOCK START
  660.              'delete from matrix
  661.                   where matrix.times = 0
  662.                     and matrix.bucketid = ?;' );                                        # PROFILE BLOCK STOP
  663.  
  664.     # Get the mapping from parameter names to ids into a local hash
  665.  
  666.     my $h = $self->{db__}->prepare( "select name, id from bucket_template;" );
  667.     $h->execute;
  668.     while ( my $row = $h->fetchrow_arrayref ) {
  669.         $self->{db_parameterid__}{$row->[0]} = $row->[1];
  670.     }
  671.     $h->finish;
  672.  
  673.     return 1;
  674. }
  675.  
  676. # ---------------------------------------------------------------------------------------------
  677. #
  678. # db_disconnect__
  679. #
  680. # Disconnect from the POPFile database
  681. #
  682. # ---------------------------------------------------------------------------------------------
  683. sub db_disconnect__
  684. {
  685.     my ( $self ) = @_;
  686.  
  687.     $self->{db_get_buckets__}->finish;
  688.     $self->{db_get_wordid__}->finish;
  689.     $self->{db_get_userid__}->finish;
  690.     $self->{db_get_word_count__}->finish;
  691.     $self->{db_put_word_count__}->finish;
  692.     $self->{db_get_bucket_unique_counts__}->finish;
  693.     $self->{db_get_bucket_word_counts__}->finish;
  694.     $self->{db_get_unique_word_count__}->finish;
  695.     $self->{db_get_full_total__}->finish;
  696.     $self->{db_get_bucket_parameter__}->finish;
  697.     $self->{db_set_bucket_parameter__}->finish;
  698.     $self->{db_get_bucket_parameter_default__}->finish;
  699.     $self->{db_get_buckets_with_magnets__}->finish;
  700.     $self->{db_delete_zero_words__}->finish;
  701.  
  702.     if ( defined( $self->{db__} ) ) {
  703.         $self->{db__}->disconnect;
  704.         undef $self->{db__};
  705.     }
  706. }
  707.  
  708. # ---------------------------------------------------------------------------------------------
  709. #
  710. # db_update_cache__
  711. #
  712. # Updates our local cache of user and bucket ids.
  713. #
  714. # $session           Must be a valid session
  715. #
  716. # ---------------------------------------------------------------------------------------------
  717. sub db_update_cache__
  718. {
  719.     my ( $self, $session ) = @_;
  720.  
  721.     my $userid = $self->valid_session_key__( $session );
  722.     return undef if ( !defined( $userid ) );
  723.  
  724.     delete $self->{db_bucketid__}{$userid};
  725.  
  726.     $self->{db_get_buckets__}->execute( $userid );
  727.     while ( my $row = $self->{db_get_buckets__}->fetchrow_arrayref ) {
  728.         $self->{db_bucketid__}{$userid}{$row->[0]}{id} = $row->[1];
  729.         $self->{db_bucketid__}{$userid}{$row->[0]}{pseudo} = $row->[2];
  730.         $self->{db_bucketcount__}{$userid}{$row->[0]} = 0;
  731.     }
  732.  
  733.     $self->{db_get_bucket_word_counts__}->execute( $userid );
  734.  
  735.     for my $b (sort keys %{$self->{db_bucketid__}{$userid}}) {
  736.         $self->{db_bucketcount__}{$userid}{$b} = 0;
  737.         $self->{db_bucketunique__}{$userid}{$b} = 0;
  738.     }
  739.  
  740.     while ( my $row = $self->{db_get_bucket_word_counts__}->fetchrow_arrayref ) {
  741.         $self->{db_bucketcount__}{$userid}{$row->[1]} = $row->[0];
  742.     }
  743.  
  744.     $self->{db_get_bucket_unique_counts__}->execute( $userid );
  745.  
  746.     while ( my $row = $self->{db_get_bucket_unique_counts__}->fetchrow_arrayref ) {
  747.         $self->{db_bucketunique__}{$userid}{$row->[1]} = $row->[0];
  748.     }
  749.  
  750.     $self->update_constants__( $session );
  751. }
  752.  
  753. # ---------------------------------------------------------------------------------------------
  754. #
  755. # db_get_word_count__
  756. #
  757. # Return the 'count' value for a word in a bucket.  If the word is not found in that
  758. # bucket then returns undef.
  759. #
  760. # $session          Valid session ID from get_session_key
  761. # $bucket           bucket word is in
  762. # $word             word to lookup
  763. #
  764. # ---------------------------------------------------------------------------------------------
  765. sub db_get_word_count__
  766. {
  767.     my ( $self, $session, $bucket, $word ) = @_;
  768.  
  769.     my $userid = $self->valid_session_key__( $session );
  770.     return undef if ( !defined( $userid ) );
  771.  
  772.     $self->{db_get_wordid__}->execute( $word );
  773.     my $result = $self->{db_get_wordid__}->fetchrow_arrayref;
  774.     if ( !defined( $result ) ) {
  775.         return undef;
  776.     }
  777.  
  778.     my $wordid = $result->[0];
  779.  
  780.     $self->{db_get_word_count__}->execute( $self->{db_bucketid__}{$userid}{$bucket}{id}, $wordid );
  781.     $result = $self->{db_get_word_count__}->fetchrow_arrayref;
  782.     if ( defined( $result ) ) {
  783.          return $result->[0];
  784.     } else {
  785.          return undef;
  786.     }
  787. }
  788.  
  789. # ---------------------------------------------------------------------------------------------
  790. #
  791. # db_put_word_count__
  792. #
  793. # Update 'count' value for a word in a bucket, if the update fails then returns 0
  794. # otherwise is returns 1
  795. #
  796. # $session          Valid session ID from get_session_key
  797. # $bucket           bucket word is in
  798. # $word             word to update
  799. # $count            new count value
  800. #
  801. # ---------------------------------------------------------------------------------------------
  802. sub db_put_word_count__
  803. {
  804.     my ( $self, $session, $bucket, $word, $count ) = @_;
  805.  
  806.     my $userid = $self->valid_session_key__( $session );
  807.     return undef if ( !defined( $userid ) );
  808.  
  809.     # We need to have two things before we can start, the id of the word in the words
  810.     # table (if there's none then we need to add the word), the bucket id in the buckets
  811.     # table (which must exist)
  812.  
  813.     $word = $self->{db__}->quote($word);
  814.  
  815.     my $result = $self->{db__}->selectrow_arrayref(
  816.                      "select words.id from words where words.word = $word limit 1;");
  817.  
  818.     if ( !defined( $result ) ) {
  819.         $self->{db__}->do( "insert into words ( word ) values ( $word );" );
  820.         $result = $self->{db__}->selectrow_arrayref(
  821.                      "select words.id from words where words.word = $word limit 1;");
  822.     }
  823.  
  824.     my $wordid = $result->[0];
  825.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  826.  
  827.     $self->{db_put_word_count__}->execute( $bucketid, $wordid, $count );
  828.  
  829.     return 1;
  830. }
  831.  
  832. # ---------------------------------------------------------------------------------------------
  833. #
  834. # upgrade_predatabase_data__
  835. #
  836. # Looks for old POPFile data (in flat files or BerkeleyDB tables) and upgrades it to the
  837. # SQL database.   Data upgraded is removed.
  838. #
  839. # ---------------------------------------------------------------------------------------------
  840. sub upgrade_predatabase_data__
  841. {
  842.     my ( $self ) = @_;
  843.     my $c      = 0;
  844.  
  845.     # There's an assumption here that this is the single user version of POPFile
  846.     # and hence what we do is cheat and get a session key assuming that the user
  847.     # name is admin with password ''
  848.  
  849.     my $session = $self->get_session_key( 'admin', '' );
  850.  
  851.     if ( !defined( $session ) ) {
  852.         $self->log_( "Tried to get the session key for user admin and failed; cannot upgrade old data" );
  853.         return;
  854.     }
  855.  
  856.     my @buckets = glob $self->get_user_path_( $self->config_( 'corpus' ) . '/*' );
  857.  
  858.     foreach my $bucket (@buckets) {
  859.  
  860.         # A bucket directory must be a directory
  861.  
  862.         next unless ( -d $bucket );
  863.         next unless ( ( -e "$bucket/table" ) || ( -e "$bucket/table.db" ) );
  864.  
  865.         return 0 if ( !$self->upgrade_bucket__( $session, $bucket ) );
  866.  
  867.         my $color = '';
  868.  
  869.         # See if there's a color file specified
  870.         if ( open COLOR, '<' . "$bucket/color" ) {
  871.             $color = <COLOR>;
  872.  
  873.             # Someone (who shall remain nameless) went in and manually created
  874.             # empty color files in their corpus directories which would cause
  875.             # $color at this point to be undefined and hence you'd get warnings
  876.             # about undefined variables below.  So this little test is to deal
  877.             # with that user and to make POPFile a little safer which is always
  878.             # a good thing
  879.  
  880.             if ( !defined( $color ) ) {
  881.                 $color = '';
  882.             } else {
  883.                 $color =~ s/[\r\n]//g;
  884.             }
  885.             close COLOR;
  886.             unlink "$bucket/color";
  887.         }
  888.  
  889.         $bucket =~ /([[:alpha:]0-9-_]+)$/;
  890.         $bucket =  $1;
  891.  
  892.         $self->set_bucket_color( $session, $bucket, ($color eq '')?$self->{possible_colors__}[$c]:$color );
  893.  
  894.         $c = ($c+1) % ($#{$self->{possible_colors__}}+1);
  895.     }
  896.  
  897.     $self->release_session_key( $session );
  898.  
  899.     return 1;
  900. }
  901.  
  902. # ---------------------------------------------------------------------------------------------
  903. #
  904. # upgrade_bucket__
  905. #
  906. # Loads an individual bucket
  907. #
  908. # $session           Valid session key from get_session_key
  909. # $bucket            The bucket name
  910. #
  911. # ---------------------------------------------------------------------------------------------
  912. sub upgrade_bucket__
  913. {
  914.     my ( $self, $session, $bucket ) = @_;
  915.  
  916.     $bucket =~ /([[:alpha:]0-9-_]+)$/;
  917.     $bucket =  $1;
  918.  
  919.     $self->create_bucket( $session, $bucket );
  920.  
  921.     if ( open PARAMS, '<' . $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/params" ) ) {
  922.         while ( <PARAMS> )  {
  923.             s/[\r\n]//g;
  924.             if ( /^([[:lower:]]+) ([^\r\n\t ]+)$/ )  {
  925.                 $self->set_bucket_parameter( $session, $bucket, $1, $2 );
  926.             }
  927.         }
  928.         close PARAMS;
  929.         unlink $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/params" );
  930.     }
  931.  
  932.     # Pre v0.21.0 POPFile had GLOBAL parameters for subject modification,
  933.     # XTC and XPL insertion.  To make the upgrade as clean as possible 
  934.     # check these parameters so that if they were OFF we set the equivalent
  935.     # per bucket to off
  936.  
  937.     foreach my $gl ( 'subject', 'xtc', 'xpl' ) {
  938.         $self->log_( "Checking deprecated parameter GLOBAL_$gl for $bucket\n" );
  939.         my $val = $self->{configuration__}->deprecated_parameter( "GLOBAL_$gl" ); 
  940.         if ( defined( $val ) && ( $val == 0 ) ) {
  941.             $self->log_( "GLOBAL_$gl is 0 for $bucket, overriding $gl\n" );
  942.             $self->set_bucket_parameter( $session, $bucket, $gl, 0 );
  943.         }
  944.     }
  945.  
  946.     # See if there are magnets defined
  947.     if ( open MAGNETS, '<' . $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/magnets" ) ) {
  948.         while ( <MAGNETS> )  {
  949.             s/[\r\n]//g;
  950.  
  951.             # Because of a bug in v0.17.9 and earlier of POPFile the text of
  952.             # some magnets was getting mangled by certain characters having
  953.             # a \ prepended.  Code here removes the \ in these cases to make
  954.             # an upgrade smooth.
  955.  
  956.             if ( /^([^ ]+) (.+)$/ )  {
  957.                 my $type  = $1;
  958.                 my $value = $2;
  959.  
  960.                 # Some people were accidently creating magnets with trailing whitespace
  961.                 # which really confused them later when their magnet did not match (see
  962.                 # comment in UI::HTML::magnet for more detail)
  963.  
  964.                 $value =~ s/^[ \t]+//g;
  965.                 $value =~ s/[ \t]+$//g;
  966.  
  967.                 $value =~ s/\\(\?|\*|\||\(|\)|\[|\]|\{|\}|\^|\$|\.)/$1/g;
  968.                 $self->create_magnet( $session, $bucket, $type, $value );
  969.             } else {
  970.  
  971.                 # This branch is used to catch the original magnets in an
  972.                 # old version of POPFile that were just there for from
  973.                 # addresses only
  974.  
  975.                 if ( /^(.+)$/ ) {
  976.                     my $value = $1;
  977.                     $value =~ s/\\(\?|\*|\||\(|\)|\[|\]|\{|\}|\^|\$|\.)/$1/g;
  978.                     $self->create_magnet( $session, $bucket, 'from', $value );
  979.                 }
  980.             }
  981.         }
  982.         close MAGNETS;
  983.         unlink $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/magnets" );
  984.     }
  985.  
  986.     # If there is no existing table but there is a table file (the old style
  987.     # flat file used by POPFile for corpus storage) then create the new
  988.     # database from it thus performing an automatic upgrade.
  989.  
  990.     if ( -e $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/table" ) ) {
  991.         $self->log_( "Performing automatic upgrade of $bucket corpus from flat file to DBI" );
  992.  
  993.         $self->{db__}->begin_work;
  994.  
  995.         if ( open WORDS, '<' . $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/table" ) )  {
  996.  
  997.             my $wc = 1;
  998.  
  999.             my $first = <WORDS>;
  1000.             if ( defined( $first ) && ( $first =~ s/^__CORPUS__ __VERSION__ (\d+)// ) ) {
  1001.                 if ( $1 != $self->{corpus_version__} )  {
  1002.                     print STDERR "Incompatible corpus version in $bucket\n";
  1003.                     close WORDS;
  1004.                     $self->{db__}->rollback;
  1005.                     return 0;
  1006.                 } else {
  1007.                    $self->log_( "Upgrading bucket $bucket..." );
  1008.  
  1009.                     while ( <WORDS> ) {
  1010.                 if ( $wc % 100 == 0 ) {
  1011.                             $self->log_( "$wc" );
  1012.                 }
  1013.                         $wc += 1;
  1014.                         s/[\r\n]//g;
  1015.  
  1016.                         if ( /^([^\s]+) (\d+)$/ ) {
  1017.                   if ( $2 != 0 ) {
  1018.                                 $self->db_put_word_count__( $session, $bucket, $1, $2 );
  1019.                 }
  1020.                         } else {
  1021.                             $self->log_( "Found entry in corpus for $bucket that looks wrong: \"$_\" (ignoring)" );
  1022.                         }
  1023.             }
  1024.                 }
  1025.  
  1026.                 if ( $wc > 1 ) {
  1027.                     $wc -= 1;
  1028.                     $self->log_( "(completed $wc words)" );
  1029.         }
  1030.                 close WORDS;
  1031.             } else {
  1032.                 close WORDS;
  1033.                 $self->{db__}->rollback;
  1034.                 unlink $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/table" );
  1035.                 return 0;
  1036.         }
  1037.  
  1038.             $self->{db__}->commit;
  1039.             unlink $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/table" );
  1040.     }
  1041.     }
  1042.  
  1043.     # Now check to see if there's a BerkeleyDB-style table
  1044.  
  1045.     my $bdb_file = $self->get_user_path_( $self->config_( 'corpus' ) . "/$bucket/table.db" );
  1046.  
  1047.     if ( -e $bdb_file ) {
  1048.         $self->log_( "Performing automatic upgrade of $bucket corpus from BerkeleyDB to DBI" );
  1049.  
  1050.         require BerkeleyDB;
  1051.  
  1052.         my %h;
  1053.         tie %h, "BerkeleyDB::Hash", -Filename => $bdb_file;
  1054.  
  1055.         $self->log_( "Upgrading bucket $bucket..." );
  1056.         $self->{db__}->begin_work;
  1057.  
  1058.         my $wc = 1;
  1059.  
  1060.         for my $word (keys %h) {
  1061.         if ( $wc % 100 == 0 ) {
  1062.                 $self->log_( "$wc" );
  1063.             }
  1064.  
  1065.             next if ( $word =~ /__POPFILE__(LOG__TOTAL|TOTAL|UNIQUE)__/ );
  1066.  
  1067.         $wc += 1;
  1068.             if ( $h{$word} != 0 ) {
  1069.                 $self->db_put_word_count__( $session, $bucket, $word, $h{$word} );
  1070.         }
  1071.     }
  1072.  
  1073.         $wc -= 1;
  1074.         $self->log_( "(completed $wc words)" );
  1075.         $self->{db__}->commit;
  1076.         untie %h;
  1077.         unlink $bdb_file;
  1078.     }
  1079.  
  1080.     return 1;
  1081. }
  1082.  
  1083. # ---------------------------------------------------------------------------------------------
  1084. #
  1085. # magnet_match_helper__
  1086. #
  1087. # Helper the determines if a specific string matches a certain magnet type in a bucket, used
  1088. # by magnet_match_
  1089. #
  1090. # $session         Valid session from get_session_key
  1091. # $match           The string to match
  1092. # $bucket          The bucket to check
  1093. # $type            The magnet type to check
  1094. #
  1095. # ---------------------------------------------------------------------------------------------
  1096. sub magnet_match_helper__
  1097. {
  1098.     my ( $self, $session, $match, $bucket, $type ) = @_;
  1099.  
  1100.     my $userid = $self->valid_session_key__( $session );
  1101.     return undef if ( !defined( $userid ) );
  1102.  
  1103.     $match = lc($match);
  1104.  
  1105.     # In Japanese and Korean mode, disable locale.
  1106.     # Sorting Japanese and Korean with "use locale" is memory and time consuming,
  1107.     # and may cause perl crash.
  1108.  
  1109.     my @magnets;
  1110.  
  1111.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  1112.     my $h = $self->{db__}->prepare(                                           # PROFILE BLOCK START
  1113.         "select magnets.val from magnets, users, buckets, magnet_types
  1114.              where buckets.id = $bucketid and
  1115.                    users.id = buckets.userid and
  1116.                    magnets.bucketid = buckets.id and
  1117.                    magnet_types.mtype = '$type' and
  1118.                    magnets.mtid = magnet_types.id order by magnets.val;" );   # PROFILE BLOCK STOP
  1119.  
  1120.     $h->execute;
  1121.     while ( my $row = $h->fetchrow_arrayref ) {
  1122.         push @magnets, ($row->[0]);
  1123.     }
  1124.     $h->finish;
  1125.  
  1126.     for my $magnet (@magnets) {
  1127.         $magnet = lc($magnet);
  1128.  
  1129.         for my $i (0..(length($match)-length($magnet))) {
  1130.             if ( substr( $match, $i, length($magnet)) eq $magnet ) {
  1131.                 $self->{scores__}        = '';
  1132.                 $self->{magnet_used__}   = 1;
  1133.                 $self->{magnet_detail__} = "$type: $magnet";
  1134.  
  1135.                 return 1;
  1136.             }
  1137.         }
  1138.     }
  1139.  
  1140.     return 0;
  1141. }
  1142.  
  1143. # ---------------------------------------------------------------------------------------------
  1144. #
  1145. # magnet_match__
  1146. #
  1147. # Helper the determines if a specific string matches a certain magnet type in a bucket
  1148. #
  1149. # $session         Valid session from get_session_key
  1150. # $match           The string to match
  1151. # $bucket          The bucket to check
  1152. # $type            The magnet type to check
  1153. #
  1154. # ---------------------------------------------------------------------------------------------
  1155. sub magnet_match__
  1156. {
  1157.     my ( $self, $session, $match, $bucket, $type ) = @_;
  1158.  
  1159.     return $self->magnet_match_helper__( $session, $match, $bucket, $type );
  1160. }
  1161.  
  1162. # ---------------------------------------------------------------------------------------------
  1163. #
  1164. # write_line__
  1165. #
  1166. # Writes a line to a file and parses it unless the classification is already known
  1167. #
  1168. # $file         File handle for file to write line to
  1169. # $line         The line to write
  1170. # $class        (optional) The current classification
  1171. #
  1172. # ---------------------------------------------------------------------------------------------
  1173. sub write_line__
  1174. {
  1175.     my ( $self, $file, $line, $class ) = @_;
  1176.  
  1177.     print $file $line if defined( $file );
  1178.  
  1179.     if ( $class eq '' ) {
  1180.         $self->{parser__}->parse_line( $line );
  1181.     }
  1182. }
  1183.  
  1184. # ---------------------------------------------------------------------------------------------
  1185. #
  1186. # add_words_to_bucket__
  1187. #
  1188. # Takes words previously parsed by the mail parser and adds/subtracts them to/from a bucket,
  1189. # this is a helper used by add_messages_to_bucket, remove_message_from_bucket
  1190. #
  1191. # $session        Valid session from get_session_key
  1192. # $bucket         Bucket to add to
  1193. # $subtract       Set to -1 means subtract the words, set to 1 means add
  1194. #
  1195. # ---------------------------------------------------------------------------------------------
  1196. sub add_words_to_bucket__
  1197. {
  1198.     my ( $self, $session, $bucket, $subtract ) = @_;
  1199.  
  1200.     my $userid = $self->valid_session_key__( $session );
  1201.     return undef if ( !defined( $userid ) );
  1202.  
  1203.     # Map the list of words to a list of counts currently in the database
  1204.     # then update those counts and write them back to the database.
  1205.  
  1206.     my $words;
  1207.     if ( $self->module_config_( 'html', 'language' ) =~ /^Nihongo|Korean$/ ) {
  1208.          no locale;
  1209.          $words = join( ',', map( $self->{db__}->quote( $_ ), (sort keys %{$self->{parser__}{words__}}) ) );
  1210.     } else {
  1211.          $words = join( ',', map( $self->{db__}->quote( $_ ), (sort keys %{$self->{parser__}{words__}}) ) );
  1212.     }
  1213.  
  1214.     $self->{get_wordids__} = $self->{db__}->prepare(        # PROFILE BLOCK START
  1215.              "select id, word
  1216.                   from words
  1217.                   where word in ( $words );" );             # PROFILE BLOCK STOP
  1218.     $self->{get_wordids__}->execute;
  1219.  
  1220.     my @id_list;
  1221.     my %wordmap;
  1222.  
  1223.     while ( my $row = $self->{get_wordids__}->fetchrow_arrayref ) {
  1224.         push @id_list, ($row->[0]);
  1225.         $wordmap{$row->[1]} = $row->[0];
  1226.     }
  1227.  
  1228.     $self->{get_wordids__}->finish;
  1229.  
  1230.     my $ids = join( ',', @id_list );
  1231.  
  1232.     $self->{db_getwords__} = $self->{db__}->prepare(                                         # PROFILE BLOCK START
  1233.              "select matrix.times, matrix.wordid
  1234.                   from matrix
  1235.                   where matrix.wordid in ( $ids )
  1236.                     and matrix.bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};" );  # PROFILE BLOCK STOP
  1237.  
  1238.     $self->{db_getwords__}->execute;
  1239.  
  1240.     my %counts;
  1241.  
  1242.     while ( my $row = $self->{db_getwords__}->fetchrow_arrayref ) {
  1243.         $counts{$row->[1]} = $row->[0];
  1244.     }
  1245.  
  1246.     $self->{db_getwords__}->finish;
  1247.  
  1248.     $self->{db__}->begin_work;
  1249.     foreach my $word (keys %{$self->{parser__}->{words__}}) {
  1250.  
  1251.         # If there's already a count then it means that the word is already
  1252.         # in the database and we have its id in $wordmap{$word} so for speed we
  1253.         # execute the db_put_word_count__ query here rather than going through
  1254.         # set_value_ which would need to look up the wordid again
  1255.  
  1256.         if ( defined( $wordmap{$word} ) && defined( $counts{$wordmap{$word}} ) ) {
  1257.             $self->{db_put_word_count__}->execute( $self->{db_bucketid__}{$userid}{$bucket}{id},               # PROFILE BLOCK START
  1258.                 $wordmap{$word}, $counts{$wordmap{$word}} + $subtract * $self->{parser__}->{words__}{$word} ); # PROFILE BLOCK STOP
  1259.     } else {
  1260.  
  1261.             # If the word is not in the database and we are trying to subtract then
  1262.             # we do nothing because negative values are meaningless
  1263.  
  1264.             if ( $subtract == 1 ) {
  1265.                 $self->db_put_word_count__( $session, $bucket, $word, $self->{parser__}->{words__}{$word} );
  1266.         }
  1267.     }
  1268.     }
  1269.  
  1270.     # If we were doing a subtract operation it's possible that some of the words
  1271.     # in the bucket now have a zero count and should be removed
  1272.  
  1273.     if ( $subtract == -1 ) {
  1274.         $self->{db_delete_zero_words__}->execute( $self->{db_bucketid__}{$userid}{$bucket}{id} );
  1275.     }
  1276.  
  1277.     $self->{db__}->commit;
  1278. }
  1279.  
  1280. # ---------------------------------------------------------------------------------------------
  1281. #
  1282. # echo_to_dot_
  1283. #
  1284. # $mail     The stream (created with IO::) to send the message to (the remote mail server)
  1285. # $client   (optional) The local mail client (created with IO::) that needs the response
  1286. # $file     (optional) A file to print the response to, caller specifies open style
  1287. # $before   (optional) String to send to client before the dot is sent
  1288. #
  1289. # echo all information from the $mail server until a single line with a . is seen
  1290. #
  1291. # NOTE Also echoes the line with . to $client but not to $file
  1292. #
  1293. # Returns 1 if there was a . or 0 if reached EOF before we hit the .
  1294. #
  1295. # ---------------------------------------------------------------------------------------------
  1296. sub echo_to_dot_
  1297. {
  1298.     my ( $self, $mail, $client, $file, $before ) = @_;
  1299.  
  1300.     my $hit_dot = 0;
  1301.  
  1302.     my $isopen = open FILE, "$file" if ( defined( $file ) );
  1303.     binmode FILE if ($isopen);
  1304.  
  1305.     while ( my $line = $self->slurp_( $mail ) ) {
  1306.  
  1307.         # Check for an abort
  1308.  
  1309.         last if ( $self->{alive_} == 0 );
  1310.  
  1311.         # The termination has to be a single line with exactly a dot on it and nothing
  1312.         # else other than line termination characters.  This is vital so that we do
  1313.         # not mistake a line beginning with . as the end of the block
  1314.  
  1315.         if ( $line =~ /^\.(\r\n|\r|\n)$/ ) {
  1316.             $hit_dot = 1;
  1317.  
  1318.             if ( defined( $before ) && ( $before ne '' ) ) {
  1319.                 print $client $before if ( defined( $client ) );
  1320.                 print FILE    $before if ( defined( $isopen ) );
  1321.             }
  1322.  
  1323.             # Note that there is no print FILE here.  This is correct because we
  1324.             # do no want the network terminator . to appear in the file version
  1325.             # of any message
  1326.  
  1327.             print $client $line if ( defined( $client ) );
  1328.             last;
  1329.         }
  1330.  
  1331.         print $client $line if ( defined( $client ) );
  1332.         print FILE    $line if ( defined( $isopen ) );
  1333.  
  1334.     }
  1335.  
  1336.     close FILE if ( $isopen );
  1337.  
  1338.     return $hit_dot;
  1339. }
  1340.  
  1341. # ---------------------------------------------------------------------------------------------
  1342. #
  1343. # substr_euc__
  1344. #
  1345. # "substr" function which supports EUC Japanese charset
  1346. #
  1347. # $pos      Start position
  1348. # $len      Word length
  1349. #
  1350. # ---------------------------------------------------------------------------------------------
  1351. sub substr_euc__
  1352. {
  1353.     my ( $str, $pos, $len ) = @_;
  1354.     my $result_str;
  1355.     my $char;
  1356.     my $count = 0;
  1357.     if ( !$pos ) {
  1358.         $pos = 0;
  1359.     }
  1360.     if ( !$len ) {
  1361.         $len = length( $str );
  1362.     }
  1363.  
  1364.     for ( $pos = 0; $count < $len; $pos++ ) {
  1365.         $char = substr( $str, $pos, 1 );
  1366.         if ( $char =~ /[\x80-\xff]/ ) {
  1367.             $char = substr( $str, $pos++, 2 );
  1368.         }
  1369.         $result_str .= $char;
  1370.         $count++;
  1371.     }
  1372.  
  1373.     return $result_str;
  1374. }
  1375.  
  1376. # ---------------------------------------------------------------------------------------------
  1377. #
  1378. # generate_unique_session_key__
  1379. #
  1380. # Returns a unique string based session key that can be used as a key in the api_sessions__
  1381. #
  1382. # ---------------------------------------------------------------------------------------------
  1383. sub generate_unique_session_key__
  1384. {
  1385.     my ( $self ) = @_;
  1386.  
  1387.     my @chars = ( 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L',   # PROFILE BLOCK START
  1388.                   'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'U', 'V', 'W', 'X', 'Y',
  1389.                   'Z', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A' ); # PROFILE BLOCK STOP
  1390.  
  1391.     my $session;
  1392.  
  1393.     do {
  1394.         $session = '';
  1395.         my $length = int( 16 + rand(4) );
  1396.  
  1397.         for my $i (0 .. $length) {
  1398.             my $random = $chars[int( rand(36) )];
  1399.  
  1400.             # Just to add spice to things we sometimes lowercase the value
  1401.  
  1402.             if ( rand(1) < rand(1) ) {
  1403.                 $random = lc($random);
  1404.             }
  1405.  
  1406.             $session .= $random;
  1407.         }
  1408.     } while ( defined( $self->{api_sessions__}{$session} ) );
  1409.  
  1410.     return $session;
  1411. }
  1412.  
  1413. # ---------------------------------------------------------------------------------------------
  1414. #
  1415. # valid_session_key__
  1416. #
  1417. # $session                Session key returned by call to get_session_key
  1418. #
  1419. # Returns undef is the session key is not valid, or returns the user ID associated
  1420. # with the session key which can be used in database accesses
  1421. #
  1422. # ---------------------------------------------------------------------------------------------
  1423. sub valid_session_key__
  1424. {
  1425.     my ( $self, $session ) = @_;
  1426.  
  1427.     # This provides protection against someone using the XML-RPC interface and calling
  1428.     # this API directly to fish for session keys, this must be called from within this
  1429.     # module
  1430.  
  1431.     return undef if ( caller ne 'Classifier::Bayes' );
  1432.  
  1433.     # If the session key is invalid then wait 1 second.  This is done to prevent
  1434.     # people from calling a POPFile API such as get_bucket_count with random session
  1435.     # keys fishing for a valid key.  The XML-RPC API is single threaded and hence this
  1436.     # will delay all use of that API by one second.  Of course in normal use when the
  1437.     # user knows the username/password or session key then there is no delay
  1438.  
  1439.     if ( !defined( $self->{api_sessions__}{$session} ) ) {
  1440.         my ( $package, $filename, $line, $subroutine ) = caller;
  1441.         $self->log_( "Invalid session key $session provided in $package @ $line" );
  1442.         select( undef, undef, undef, 1 );
  1443.     }
  1444.  
  1445.     return $self->{api_sessions__}{$session};
  1446. }
  1447.  
  1448. # ---------------------------------------------------------------------------------------------
  1449. # ---------------------------------------------------------------------------------------------
  1450. #       _____   _____   _____  _______ _____        _______     _______  _____  _____
  1451. #      |_____] |     | |_____] |______   |   |      |______     |_____| |_____]   |
  1452. #      |       |_____| |       |       __|__ |_____ |______     |     | |       __|__
  1453. #
  1454. # The method below are public and may be accessed by other modules.  All of them may be
  1455. # accessed remotely through the XMLRPC.pm module using the XML-RPC protocol
  1456. #
  1457. # Note that every API function expects to be passed a $session which is obtained by first
  1458. # calling get_session_key with a valid username and password.   Once done call the method
  1459. # release_session_key.
  1460. #
  1461. # ---------------------------------------------------------------------------------------------
  1462. # ---------------------------------------------------------------------------------------------
  1463.  
  1464. # ---------------------------------------------------------------------------------------------
  1465. #
  1466. # get_session_key
  1467. #
  1468. # $user           The name of an existing user
  1469. # $pwd            The user's password
  1470. #
  1471. # Returns a string based session key if the username and password match, or undef if not
  1472. #
  1473. # ---------------------------------------------------------------------------------------------
  1474. sub get_session_key
  1475. {
  1476.     my ( $self, $user, $pwd ) = @_;
  1477.  
  1478.     # The password is stored in the database as an MD5 hash of the username and
  1479.     # password concatenated and separated by the string __popfile__, so compute
  1480.     # the hash here
  1481.  
  1482.     my $hash = md5_hex( $user . '__popfile__' . $pwd );
  1483.  
  1484.     $self->{db_get_userid__}->execute( $user, $hash );
  1485.     my $result = $self->{db_get_userid__}->fetchrow_arrayref;
  1486.     if ( !defined( $result ) ) {
  1487.  
  1488.         # The delay of one second here is to prevent people from trying out
  1489.         # username/password combinations at high speed to determine the
  1490.         # credentials of a valid user
  1491.  
  1492.         $self->log_( "Attempt to login with incorrect credentials for user $user" );
  1493.         select( undef, undef, undef, 1 );
  1494.         return undef;
  1495.     }
  1496.  
  1497.     my $session = $self->generate_unique_session_key__();
  1498.  
  1499.     $self->{api_sessions__}{$session} = $result->[0];
  1500.  
  1501.     $self->db_update_cache__( $session );
  1502.  
  1503.     $self->log_( "get_session_key returning key $session for user $self->{api_sessions__}{$session}" );
  1504.  
  1505.     return $session;
  1506. }
  1507.  
  1508. # ---------------------------------------------------------------------------------------------
  1509. #
  1510. # release_session_key
  1511. #
  1512. # $session        A session key previously returned by get_session_key
  1513. #
  1514. # Releases and invalidates the session key
  1515. #
  1516. # ---------------------------------------------------------------------------------------------
  1517. sub release_session_key
  1518. {
  1519.     my ( $self, $session ) = @_;
  1520.  
  1521.     if ( defined( $self->{api_sessions__}{$session} ) ) {
  1522.         $self->log_( "release_session_key releasing key $session for user $self->{api_sessions__}{$session}" );
  1523.         delete $self->{api_sessions__}{$session};
  1524.     }
  1525. }
  1526.  
  1527. # ---------------------------------------------------------------------------------------------
  1528. #
  1529. # get_top_bucket__
  1530. #
  1531. # Helper function used by classify to get the bucket with the highest score from data
  1532. # stored in a matrix of information (see definition of %matrix in classify for details)
  1533. # and a list of potential buckets
  1534. #
  1535. # $userid         User ID for database access
  1536. # $id             ID of a word in $matrix
  1537. # $matrix         Reference to the %matrix hash in classify
  1538. # $buckets        Reference to a list of buckets
  1539. #
  1540. # Returns the bucket in $buckets with the highest score
  1541. #
  1542. # ---------------------------------------------------------------------------------------------
  1543. sub get_top_bucket__
  1544. {
  1545.     my ( $self, $userid, $id, $matrix, $buckets ) = @_;
  1546.  
  1547.     my $best_probability = 0;
  1548.     my $top_bucket       = 'unclassified';
  1549.  
  1550.     for my $bucket (@$buckets) {
  1551.         my $probability = 0;
  1552.         if ( defined($$matrix{$id}{$bucket}) && ( $$matrix{$id}{$bucket} > 0 ) ) {
  1553.             $probability = $$matrix{$id}{$bucket} / $self->{db_bucketcount__}{$userid}{$bucket};
  1554.         }
  1555.  
  1556.         if ( $probability > $best_probability ) {
  1557.             $best_probability = $probability;
  1558.             $top_bucket       = $bucket;
  1559.     }
  1560.     }
  1561.  
  1562.     return $top_bucket;
  1563. }
  1564.  
  1565. # ---------------------------------------------------------------------------------------------
  1566. #
  1567. # classify
  1568. #
  1569. # $session   A valid session key returned by a call to get_session_key
  1570. # $file      The name of the file containing the text to classify (or undef to use
  1571. #            the data already in the parser)
  1572. # $ui        Reference to the UI used when doing colorization
  1573. # $matrix    (optional) Reference to a hash that will be filled with the word matrix
  1574. #            used in classification
  1575. # $idmap     (optional) Reference to a hash that will map word ids in the $matrix to
  1576. #            actual words
  1577. #
  1578. # Splits the mail message into valid words, then runs the Bayes algorithm to figure out
  1579. # which bucket it belongs in.  Returns the bucket name
  1580. #
  1581. # ---------------------------------------------------------------------------------------------
  1582. sub classify
  1583. {
  1584.     my ( $self, $session, $file, $ui, $matrix, $idmap ) = @_;
  1585.     my $msg_total = 0;
  1586.  
  1587.     my $userid = $self->valid_session_key__( $session );
  1588.     return undef if ( !defined( $userid ) );
  1589.  
  1590.     $self->{unclassified__} = log( $self->config_( 'unclassified_weight' ) );
  1591.  
  1592.     # Pass language parameter to parse_file()
  1593.  
  1594.     $self->{magnet_used__}   = 0;
  1595.     $self->{magnet_detail__} = '';
  1596.  
  1597.     if ( defined( $file ) ) {
  1598.         $self->{parser__}->parse_file( $file,                                           # PROFILE BLOCK START
  1599.                                        $self->module_config_( 'html', 'language' ),
  1600.                                        $self->global_config_( 'message_cutoff'   ) );   # PROFILE BLOCK STOP
  1601.     }
  1602.  
  1603.     # Check to see if this email should be classified based on a magnet
  1604.     # Get the list of buckets
  1605.  
  1606.     my @buckets = $self->get_buckets( $session );
  1607.  
  1608.     for my $bucket ($self->get_buckets_with_magnets( $session ))  {
  1609.         for my $type ($self->get_magnet_types_in_bucket( $session, $bucket )) {
  1610.         if ( $self->magnet_match__( $session, $self->{parser__}->get_header($type), $bucket, $type ) ) {
  1611.                 return $bucket;
  1612.             }
  1613.         }
  1614.     }
  1615.  
  1616.     # If the user has not defined any buckets then we escape here return unclassified
  1617.  
  1618.     return "unclassified" if ( $#buckets == -1 );
  1619.  
  1620.     # The score hash will contain the likelihood that the given message is in each
  1621.     # bucket, the buckets are the keys for score
  1622.  
  1623.     # Set up the initial score as P(bucket)
  1624.  
  1625.     my %score;
  1626.     my %matchcount;
  1627.  
  1628.     # Build up a list of the buckets that are OK to use for classification (i.e.
  1629.     # that have at least one word in them).
  1630.  
  1631.     my @ok_buckets;
  1632.  
  1633.     for my $bucket (@buckets) {
  1634.         if ( $self->{bucket_start__}{$userid}{$bucket} != 0 ) {
  1635.             $score{$bucket} = $self->{bucket_start__}{$userid}{$bucket};
  1636.             $matchcount{$bucket} = 0;
  1637.             push @ok_buckets, ( $bucket );
  1638.     }
  1639.     }
  1640.  
  1641.     @buckets = @ok_buckets;
  1642.  
  1643.     # For each word go through the buckets and calculate P(word|bucket) and then calculate
  1644.     # P(word|bucket) ^ word count and multiply to the score
  1645.  
  1646.     my $word_count = 0;
  1647.  
  1648.     # The correction value is used to generate score displays in the scores__
  1649.     # variable which are consistent with the word scores shown by the GUI's
  1650.     # word lookup feature.  It is computed to make the contribution of a word
  1651.     # which is unrepresented in a bucket zero.  This correction affects only
  1652.     # the values displayed in scores__; it has no effect on the classification
  1653.     # process.
  1654.  
  1655.     my $correction = 0;
  1656.  
  1657.     # Classification against the database works in a sequence of steps to get
  1658.     # the fastest time possible.  The steps are as follows:
  1659.     #
  1660.     # 1. Convert the list of words returned by the parser into a list of unique
  1661.     #    word ids that can be used in the database.  This requires a select
  1662.     #    against the database to get the word ids (and associated words) which
  1663.     #    is then converted into two things: @id_list which is just the sorted
  1664.     #    list of word ids and %idmap which maps a word to its id.
  1665.     #
  1666.     # 2. Then run a second select that get the triplet (count, id, bucket) for
  1667.     #    each word id and each bucket.  The triplet contains the word count from
  1668.     #    the database for each bucket and each id, where there is an entry. That
  1669.     #    data gets loaded into the sparse matrix %matrix.
  1670.     #
  1671.     # 3. Do the normal classification loop as before running against the @id_list
  1672.     #    for the words and for each bucket.   If there's an entry in %matrix for
  1673.     #    the id/bucket combination then calculate the probability, otherwise use
  1674.     #    the not_likely probability.
  1675.     #
  1676.     # NOTE.  Since there is a single not_likely probability we do not worry about
  1677.     #        the fact that the select in 1 might return a shorter list of words
  1678.     #        than was found in the message (because some words are not in the
  1679.     #        database) since the missing words will be the same for all buckets
  1680.     #        and hence constitute a fixed scaling factor on all the buckets which
  1681.     #        is irrelevant in deciding which the winning bucket is.
  1682.  
  1683.     my $words;
  1684.     if ( $self->module_config_( 'html', 'language' ) =~ /^Nihongo|Korean$/ ) {
  1685.         no locale;
  1686.         $words = join( ',', map( $self->{db__}->quote( $_ ), (sort keys %{$self->{parser__}{words__}}) ) );
  1687.     } else {
  1688.         $words = join( ',', map( $self->{db__}->quote( $_ ), (sort keys %{$self->{parser__}{words__}}) ) );
  1689.     }
  1690.  
  1691.     $self->{get_wordids__} = $self->{db__}->prepare(  # PROFILE BLOCK START
  1692.              "select id, word
  1693.                   from words
  1694.                   where word in ( $words )
  1695.                   order by id;" );                    # PROFILE BLOCK STOP
  1696.     $self->{get_wordids__}->execute;
  1697.  
  1698.     my @id_list;
  1699.     my %temp_idmap;
  1700.  
  1701.     if ( !defined( $idmap ) ) {
  1702.         $idmap = \%temp_idmap;
  1703.     }
  1704.  
  1705.     while ( my $row = $self->{get_wordids__}->fetchrow_arrayref ) {
  1706.         push @id_list, ($row->[0]);
  1707.         $$idmap{$row->[0]} = $row->[1];
  1708.     }
  1709.  
  1710.     $self->{get_wordids__}->finish;
  1711.  
  1712.     my $ids = join( ',', @id_list );
  1713.  
  1714.     $self->{db_classify__} = $self->{db__}->prepare(            # PROFILE BLOCK START
  1715.              "select matrix.times, matrix.wordid, buckets.name
  1716.                   from matrix, buckets
  1717.                   where matrix.wordid in ( $ids )
  1718.                     and matrix.bucketid = buckets.id
  1719.                     and buckets.userid = $userid;" );           # PROFILE BLOCK STOP
  1720.  
  1721.     $self->{db_classify__}->execute;
  1722.  
  1723.     # %matrix maps wordids and bucket names to counts
  1724.     # $matrix{$wordid}{$bucket} == $count
  1725.  
  1726.     my %temp_matrix;
  1727.  
  1728.     if ( !defined( $matrix ) ) {
  1729.         $matrix = \%temp_matrix;
  1730.     }
  1731.  
  1732.     while ( my $row = $self->{db_classify__}->fetchrow_arrayref ) {
  1733.         $$matrix{$row->[1]}{$row->[2]} = $row->[0];
  1734.     }
  1735.  
  1736.     $self->{db_classify__}->finish;
  1737.  
  1738.  
  1739.     foreach my $id (@id_list) {
  1740.         $word_count += 2;
  1741.         my $wmax = -10000;
  1742.  
  1743.         foreach my $bucket (@buckets) {
  1744.             my $probability = 0;
  1745.  
  1746.             if ( defined($$matrix{$id}{$bucket}) && ( $$matrix{$id}{$bucket} > 0 ) ) {
  1747.                 $probability = log( $$matrix{$id}{$bucket} / $self->{db_bucketcount__}{$userid}{$bucket} );
  1748.         }
  1749.  
  1750.             $matchcount{$bucket} += $self->{parser__}{words__}{$$idmap{$id}} if ($probability != 0);
  1751.             $probability = $self->{not_likely__}{$userid} if ( $probability == 0 );
  1752.             $wmax = $probability if ( $wmax < $probability );
  1753.             $score{$bucket} += ( $probability * $self->{parser__}{words__}{$$idmap{$id}} );
  1754.         }
  1755.  
  1756.         if ($wmax > $self->{not_likely__}{$userid}) {
  1757.             $correction += $self->{not_likely__}{$userid} * $self->{parser__}{words__}{$$idmap{$id}};
  1758.         } else {
  1759.             $correction += $wmax * $self->{parser__}{words__}{$$idmap{$id}};
  1760.         }
  1761.     }
  1762.  
  1763.     # Now sort the scores to find the highest and return that bucket as the classification
  1764.  
  1765.     my @ranking = sort {$score{$b} <=> $score{$a}} keys %score;
  1766.  
  1767.     my %raw_score;
  1768.     my $base_score = $score{$ranking[0]};
  1769.     my $total = 0;
  1770.  
  1771.     # If the first and second bucket are too close in their probabilities, call the message
  1772.     # unclassified.  Also if there are fewer than 2 buckets.
  1773.     my $class = 'unclassified';
  1774.  
  1775.     if ( @buckets > 1 && $score{$ranking[0]} > ( $score{$ranking[1]} + $self->{unclassified__} ) ) {
  1776.         $class = $ranking[0];
  1777.     }
  1778.  
  1779.     # Compute the total of all the scores to generate the normalized scores and probability
  1780.     # estimate.  $total is always 1 after the first loop iteration, so any additional term
  1781.     # less than 2 ** -54 is insignificant, and need not be computed.
  1782.  
  1783.     my $ln2p_54 = -54 * log(2);
  1784.  
  1785.     foreach my $b (@ranking) {
  1786.         $raw_score{$b} = $score{$b};
  1787.         $score{$b} -= $base_score;
  1788.  
  1789.         $total += exp($score{$b}) if ($score{$b} > $ln2p_54 );
  1790.     }
  1791.  
  1792.     if ($self->{wordscores__} && defined($ui) ) {
  1793.         my %qm = %{$self->{parser__}->quickmagnets()};
  1794.         my $mlen = scalar(keys %{$self->{parser__}->quickmagnets()});
  1795.         my %language    = $ui->language();
  1796.         my $session_key = $ui->session_key();
  1797.  
  1798.         if ( $mlen >= 0 ) {
  1799.             my @buckets = $self->get_buckets( $session );
  1800.             my $i = 0;
  1801.             $self->{scores__} .= "<form action=\"/magnets\" method=\"get\">\n";
  1802.             $self->{scores__} .= "<input type=\"hidden\" name=\"session\" value=\"$session_key\" />";
  1803.             $self->{scores__} .= "<input type=\"hidden\" name=\"count\" value=\"" . ($mlen + 1) . "\" />";
  1804.             $self->{scores__} .= "<hr><b>$language{QuickMagnets}</b><p>\n<table class=\"top20Words\">\n<tr>\n<th scope=\"col\">$language{Magnet}</th>\n<th>$language{Magnet_Always}</th>\n";
  1805.  
  1806.             my %types = $self->get_magnet_types( $session );
  1807.  
  1808.             foreach my $type ( sort keys %types ) {
  1809.  
  1810.                 if (defined $qm{$type}) {
  1811.                     $i += 1;
  1812.  
  1813.                     $self->{scores__} .= "<tr><td scope=\"col\">$type: ";
  1814.                     $self->{scores__} .= "<select name=\"text$i\" id=\"\">\n";
  1815.  
  1816.                     foreach my $magnet ( @{$qm{$type}} ) {
  1817.                         $self->{scores__} .= "<option value=\"$magnet\">$magnet</option>\n";
  1818.                     }
  1819.                     $self->{scores__} .= "</select>\n";
  1820.                     $self->{scores__} .= "</td><td>";
  1821.                     $self->{scores__} .= "<input type=\"hidden\" name=\"type$i\" id=\"magnetsAddType\" value=\"$type\"/>";
  1822.                     $self->{scores__} .= "<select name=\"bucket$i\" id=\"magnetsAddBucket\">\n<option value=\"\"></option>\n";
  1823.  
  1824.                     foreach my $bucket (@buckets) {
  1825.                         $self->{scores__} .= "<option value=\"$bucket\">$bucket</option>\n";
  1826.                     }
  1827.  
  1828.                     $self->{scores__} .= "</select></td></tr>";
  1829.                 }
  1830.             }
  1831.  
  1832.             $self->{scores__} .= "<tr><td></td><td><input type=\"submit\" class=\"submit\" name=\"create\" value=\"$language{Create}\" /></td></tr></table></form>";
  1833.         }
  1834.  
  1835.         $self->{scores__} .= "<a name=\"scores\">";
  1836.         $self->{scores__} .= "<hr><b>$language{Scores}</b><p>\n";
  1837.  
  1838.         $self->{scores__} .= "<table class=\"top20Words\">\n<tr>\n<th scope=\"col\">$language{Bucket}</th>\n<th> </th>\n";
  1839.         if ($self->{wmformat__} eq 'score') {
  1840.             $self->{scores__} .= "<th scope=\"col\">$language{Count}  </th><th scope=\"col\" align=\"center\">$language{Score}</th><th scope=\"col\">$language{Probability}</th></tr>\n";
  1841.         } else {
  1842.             $self->{scores__} .= "<th scope=\"col\">$language{Count}  </th><th scope=\"col\">$language{Probability}</th></tr>\n";
  1843.         }
  1844.  
  1845.         my $log10 = log(10.0);
  1846.  
  1847.         foreach my $b (@ranking) {
  1848.              my $prob = exp($score{$b})/$total;
  1849.              my $probstr;
  1850.              my $rawstr;
  1851.  
  1852.              # If the computed probability would display as 1, display it as .999999 instead.
  1853.              # We don't want to give the impression that POPFile is ever completely sure of its
  1854.              # classification.
  1855.  
  1856.              if ($prob >= .999999) {
  1857.                  $probstr = sprintf("%12.6f", 0.999999);
  1858.              } else {
  1859.                  if ($prob >= 0.1 || $prob == 0.0) {
  1860.                      $probstr = sprintf("%12.6f", $prob);
  1861.                  } else {
  1862.                     $probstr = sprintf("%17.6e", $prob);
  1863.                  }
  1864.              }
  1865.  
  1866.              my $color = $self->get_bucket_color( $session, $b );
  1867.  
  1868.              if ($self->{wmformat__} eq 'score') {
  1869.                 $rawstr = sprintf("%12.6f", ($raw_score{$b} - $correction)/$log10);
  1870.                 $self->{scores__} .= "<tr>\n<td><font color=\"$color\"><b>$b</b></font></td>\n<td> </td>\n<td align=\"right\">$matchcount{$b}    </td>\n<td align=right>$rawstr   </td>\n<td>$probstr</td>\n</tr>\n";
  1871.              } else {
  1872.                 $self->{scores__} .= "<tr>\n<td><font color=\"$color\"><b>$b</b></font></td>\n<td> </td>\n<td align=\"right\">$matchcount{$b}    </td>\n<td>$probstr</td>\n</tr>\n";
  1873.              }
  1874.         }
  1875.  
  1876.         $self->{scores__} .= "</table><hr>";
  1877.  
  1878.         # We want a link to change the format here.  But only the UI knows how to build
  1879.         # that link.  So we just insert a comment which can be replaced by the UI.  There's
  1880.         # probably a better way.
  1881.  
  1882.         $self->{scores__} .= "<!--format--><p>";
  1883.         if ( $self->{wmformat__} ne '' ) {
  1884.             $self->{scores__} .= "<table class=\"top20Words\">\n";
  1885.             $self->{scores__} .= "<tr>\n<th scope=\"col\">$language{Word}</th><th> </th><th scope=\"col\">$language{Count}</th><th> </th>\n";
  1886.  
  1887.             foreach my $ix (0..($#buckets > 7? 7: $#buckets)) {
  1888.                 my $bucket = $ranking[$ix];
  1889.                 my $bucketcolor  = $self->get_bucket_color( $session, $bucket );
  1890.                 $self->{scores__} .= "<th><font color=\"$bucketcolor\">$bucket</font></th><th> </th>";
  1891.             }
  1892.  
  1893.             $self->{scores__} .= "</tr>";
  1894.  
  1895.             my %wordprobs;
  1896.  
  1897.             # If the word matrix is supposed to show probabilities, compute them,
  1898.             # saving the results in %wordprobs.
  1899.  
  1900.             if ( $self->{wmformat__} eq 'prob') {
  1901.                 foreach my $id (@id_list) {
  1902.                     my $sumfreq = 0;
  1903.                     my %wval;
  1904.                     foreach my $bucket (@ranking) {
  1905.                         $wval{$bucket} = $$matrix{$id}{$bucket} || 0;
  1906.                         $sumfreq += $wval{$bucket};
  1907.                     }
  1908.  
  1909.                     # If $sumfreq is still zero then this word didn't appear in any buckets
  1910.                     # so we shouldn't create wordprobs entries for it
  1911.  
  1912.                     if ( $sumfreq != 0 ) {
  1913.                         foreach my $bucket (@ranking) {
  1914.                             $wordprobs{$bucket,$id} = $wval{$bucket} / $sumfreq;
  1915.                         }
  1916.             }
  1917.                 }
  1918.             }
  1919.  
  1920.             my @ranked_ids;
  1921.             if ($self->{wmformat__} eq 'prob') {
  1922.                 @ranked_ids = sort {($wordprobs{$ranking[0],$b}||0) <=> ($wordprobs{$ranking[0],$a}||0)} @id_list;
  1923.             } else {
  1924.                 @ranked_ids = sort {($$matrix{$b}{$ranking[0]}||0) <=> ($$matrix{$a}{$ranking[0]}||0)} @id_list;
  1925.             }
  1926.  
  1927.             foreach my $id (@ranked_ids) {
  1928.                 my $known = 0;
  1929.  
  1930.                 foreach my $bucket (@ranking) {
  1931.                     if ( defined( $$matrix{$id}{$bucket} ) ) {
  1932.                         $known = 1;
  1933.                         last;
  1934.                     }
  1935.                 }
  1936.  
  1937.                 if ( $known == 1 ) {
  1938.                     my $wordcolor = $self->get_bucket_color( $session, $self->get_top_bucket__( $userid, $id, $matrix, \@ranking ) );
  1939.                     my $count = $self->{parser__}->{words__}{$$idmap{$id}};
  1940.  
  1941.                     $self->{scores__} .= "<tr>\n<td><font color=\"$wordcolor\">$$idmap{$id}</font></td><td> </td><td>$count</td><td> </td>\n";
  1942.  
  1943.                     my $base_probability = 0;
  1944.                     if ( defined($$matrix{$id}{$ranking[0]}) && ( $$matrix{$id}{$ranking[0]} > 0 ) ) {
  1945.                         $base_probability = log( $$matrix{$id}{$ranking[0]} / $self->{db_bucketcount__}{$userid}{$ranking[0]} );
  1946.                 }
  1947.  
  1948.                     foreach my $ix (0..($#buckets > 7? 7: $#buckets)) {
  1949.                         my $bucket = $ranking[$ix];
  1950.                         my $probability = 0;
  1951.                         if ( defined($$matrix{$id}{$bucket}) && ( $$matrix{$id}{$bucket} > 0 ) ) {
  1952.                             $probability = log( $$matrix{$id}{$bucket} / $self->{db_bucketcount__}{$userid}{$bucket} );
  1953.                     }
  1954.                         my $color        = 'black';
  1955.  
  1956.                         if ( $probability >= $base_probability || $base_probability == 0 ) {
  1957.                             $color = $self->get_bucket_color( $session, $bucket );
  1958.                         }
  1959.  
  1960.                         if ( $probability != 0 ) {
  1961.                             my $wordprobstr;
  1962.                             if ($self->{wmformat__} eq 'score') {
  1963.                                 $wordprobstr  = sprintf("%12.4f", ($probability - $self->{not_likely__}{$userid})/$log10 );
  1964.                             } else {
  1965.                                 if ($self->{wmformat__} eq 'prob') {
  1966.                                     $wordprobstr  = sprintf("%12.4f", $wordprobs{$bucket,$id});
  1967.                                 } else {
  1968.                                     $wordprobstr  = sprintf("%13.5f", exp($probability) );
  1969.                                 }
  1970.                             }
  1971.  
  1972.                             $self->{scores__} .= "<td><font color=\"$color\">$wordprobstr</font></td>\n<td> </td>\n";
  1973.                         } else {
  1974.                             $self->{scores__} .= "<td> </td>\n<td> </td>\n";
  1975.                         }
  1976.                     }
  1977.                 }
  1978.  
  1979.                 $self->{scores__} .= "</tr>";
  1980.             }
  1981.  
  1982.             $self->{scores__} .= "</table></p>";
  1983.         }
  1984.     }
  1985.  
  1986.     return $class;
  1987. }
  1988.  
  1989. # ---------------------------------------------------------------------------------------------
  1990. #
  1991. # history_filename
  1992. #
  1993. # Returns a path and filename for a POPFile message based on the session count and message count
  1994. #
  1995. # $dcount   - the unique download/session count for this message
  1996. # $mcount   - the message count for this message
  1997. # $ext      - the extension for this message (defaults to .msg)
  1998. # $path     - 1 to return the path configuration info, 0 to return just the filename (default 0)
  1999. #
  2000. # ---------------------------------------------------------------------------------------------
  2001. sub history_filename
  2002. {
  2003.     my ( $self, $dcount, $mcount, $ext, $path) = @_;
  2004.  
  2005.     $path = 0 if (!defined($path));
  2006.  
  2007.     return ($path?$self->get_user_path_( $self->global_config_( 'msgdir' ) ):'') . "popfile$dcount" . "=$mcount" . (defined $ext?$ext:'.msg');
  2008. }
  2009.  
  2010. # ---------------------------------------------------------------------------------------------
  2011. #
  2012. # history_write_class - write the class file for a message.
  2013. #
  2014. # $filename     The name of the message to write the class for
  2015. # $reclassified Boolean, true if the message has been reclassified
  2016. # $bucket       the name of the bucket the message is in
  2017. # $usedtobe     the name of the bucket the messages used to be in
  2018. # $magnet       the magnet, if any, used to reclassify the message
  2019. #
  2020. # ---------------------------------------------------------------------------------------------
  2021. sub history_write_class
  2022. {
  2023.     my ( $self, $filename, $reclassified, $bucket, $usedtobe, $magnet ) = @_;
  2024.  
  2025.     $filename =~ s/msg$/cls/;
  2026.     $filename =  $self->get_user_path_( $self->global_config_( 'msgdir' ) . $filename );
  2027.  
  2028.     open CLASS, ">$filename";
  2029.  
  2030.     if ( defined( $magnet ) && ( $magnet ne '' ) ) {
  2031.         print CLASS "$bucket MAGNET $magnet\n";
  2032.     } else {
  2033.         if ( defined( $reclassified ) && ( $reclassified == 1 ) ) {
  2034.             print CLASS "RECLASSIFIED\n";
  2035.             print CLASS "$bucket\n";
  2036.             if ( defined( $usedtobe ) && ( $usedtobe ne '' ) ) {
  2037.                print CLASS "$usedtobe\n";
  2038.             }
  2039.         } else {
  2040.             print CLASS "$bucket\n";
  2041.         }
  2042.     }
  2043.  
  2044.     close CLASS;
  2045. }
  2046.  
  2047. # ---------------------------------------------------------------------------------------------
  2048. #
  2049. # history_read_class - load the class file for a message.
  2050. #
  2051. # returns: ( reclassified, bucket, usedtobe, magnet )
  2052. #   values:
  2053. #       reclassified:   boolean, true if message has been reclassified
  2054. #       bucket:         string, the bucket the message is in presently, unknown class if an error occurs
  2055. #       usedtobe:       string, the bucket the message used to be in (null if not reclassified)
  2056. #       magnet:         string, the magnet
  2057. #
  2058. # $filename     The name of the message to load the class for
  2059. #
  2060. # ---------------------------------------------------------------------------------------------
  2061. sub history_read_class
  2062. {
  2063.     my ( $self, $filename ) = @_;
  2064.  
  2065.     $filename =~ s/msg$/cls/;
  2066.  
  2067.     my $reclassified = 0;
  2068.     my $bucket = 'unknown class';
  2069.     my $usedtobe;
  2070.     my $magnet = '';
  2071.  
  2072.     if ( open CLASS, '<' . $self->get_user_path_( $self->global_config_( 'msgdir' ) . $filename ) ) {
  2073.         $bucket = <CLASS>;
  2074.         if ( defined( $bucket ) && ( $bucket =~ /([^ ]+) MAGNET ([^\r\n]+)/ ) ) {
  2075.             $bucket = $1;
  2076.             $magnet = $2;
  2077.         }
  2078.  
  2079.         $reclassified = 0;
  2080.         if ( defined( $bucket ) && ( $bucket =~ /RECLASSIFIED/ ) ) {
  2081.             $bucket       = <CLASS>;
  2082.             $usedtobe = <CLASS>;
  2083.             $reclassified = 1;
  2084.             $usedtobe =~ s/[\r\n]//g;
  2085.         }
  2086.         close CLASS;
  2087.         $bucket =~ s/[\r\n]//g if defined( $bucket );
  2088.     } else {
  2089.         $self->log_( "Error: " . $self->get_user_path_( $self->global_config_( 'msgdir' ) . "$filename: $!" ) );
  2090.  
  2091.         return ( undef, $bucket, undef, undef );
  2092.     }
  2093.  
  2094.     $bucket = 'unknown class' if ( !defined( $bucket ) );
  2095.  
  2096.     return ( $reclassified, $bucket, $usedtobe, $magnet );
  2097. }
  2098.  
  2099. # ---------------------------------------------------------------------------------------------
  2100. #
  2101. # classify_and_modify
  2102. #
  2103. # This method reads an email terminated by . on a line by itself (or the end of stream)
  2104. # from a handle and creates an entry in the history, outputting the same email on another
  2105. # handle with the appropriate header modifications and insertions
  2106. #
  2107. # $session   A valid session key returned by a call to get_session_key
  2108. # $mail     - an open stream to read the email from
  2109. # $client   - an open stream to write the modified email to
  2110. # $dcount   - the unique download count for this message
  2111. # $mcount   - the message count for this message
  2112. # $nosave   - indicates that the message downloaded should not be saved in the history
  2113. # $class    - if we already know the classification
  2114. # $echo     - 1 to echo to the client, 0 to supress, defaults to 1
  2115. # $crlf     - The sequence to use at the end of a line in the output, normally
  2116. #             this is left undefined and this method uses $eol (the normal network end
  2117. #             of line), but if this method is being used with real files you may wish
  2118. #             to pass in \n instead
  2119. #
  2120. # Returns a classification if it worked and the name of the file where the message
  2121. # was saved
  2122. #
  2123. # IMPORTANT NOTE: $mail and $client should be binmode
  2124. #
  2125. # ---------------------------------------------------------------------------------------------
  2126. sub classify_and_modify
  2127. {
  2128.     my ( $self, $session, $mail, $client, $dcount, $mcount, $nosave, $class, $echo, $crlf ) = @_;
  2129.  
  2130.     $echo = 1    unless (defined $echo);
  2131.     $crlf = $eol unless (defined $crlf);
  2132.  
  2133.     my $msg_subject;              # The message subject
  2134.     my $msg_head_before = '';     # Store the message headers that come before Subject here
  2135.     my $msg_head_after  = '';     # Store the message headers that come after Subject here
  2136.     my $msg_head_q      = '';     # Store questionable header lines here
  2137.     my $msg_body        = '';     # Store the message body here
  2138.  
  2139.     # These two variables are used to control the insertion of the X-POPFile-TimeoutPrevention
  2140.     # header when downloading long or slow emails
  2141.     my $last_timeout   = time;
  2142.     my $timeout_count  = 0;
  2143.  
  2144.     # Indicates whether the first time through the receive loop we got the full body, this
  2145.     # will happen on small emails
  2146.     my $got_full_body  = 0;
  2147.  
  2148.     # The size of the message downloaded so far.
  2149.     my $message_size   = 0;
  2150.  
  2151.     # The classification for this message
  2152.     my $classification = '';
  2153.  
  2154.     # Whether we are currently reading the mail headers or not
  2155.     my $getting_headers = 1;
  2156.  
  2157.     my $msg_file  = $self->history_filename($dcount,$mcount, ".msg",1);
  2158.     my $temp_file = "$msg_file.tmp";
  2159.     my $nopath_temp_file = $self->history_filename($dcount,$mcount,".msg",0);
  2160.  
  2161.     # Get the class-file info without the path, since we'd just need to strip it
  2162.     my $class_file = $self->history_filename($dcount,$mcount, ".cls",0);
  2163.  
  2164.     # If we don't yet know the classification then start the parser
  2165.     if ( $class eq '' ) {
  2166.         $self->{parser__}->start_parse();
  2167.     }
  2168.  
  2169.     # We append .TMP to the filename for the MSG file so that if we are in
  2170.     # middle of downloading a message and we refresh the history we do not
  2171.     # get class file errors
  2172.  
  2173.     open TEMP, ">$temp_file" unless $nosave;
  2174.  
  2175.     while ( my $line = $self->slurp_( $mail ) ) {
  2176.         my $fileline;
  2177.  
  2178.         # This is done so that we remove the network style end of line CR LF
  2179.         # and allow Perl to decide on the local system EOL which it will expand
  2180.         # out of \n when this gets written to the temp file
  2181.  
  2182.         $fileline = $line;
  2183.         $fileline =~ s/[\r\n]//g;
  2184.         $fileline .= "\n";
  2185.  
  2186.         # Check for an abort
  2187.  
  2188.         last if ( $self->{alive_} == 0 );
  2189.  
  2190.         # The termination of a message is a line consisting of exactly .CRLF so we detect that
  2191.         # here exactly
  2192.  
  2193.         if ( $line =~ /^\.(\r\n|\r|\n)$/ ) {
  2194.             $got_full_body = 1;
  2195.             last;
  2196.         }
  2197.  
  2198.         if ( $getting_headers )  {
  2199.  
  2200.             # Kill header lines containing only whitespace (Exim does this)
  2201.  
  2202.             next if ( $line =~ /^[ \t]+(\r\n|\r|\n)$/i );
  2203.  
  2204.             if ( !( $line =~ /^(\r\n|\r|\n)$/i ) )  {
  2205.                 $message_size += length $line;
  2206.                 $self->write_line__( $nosave?undef:\*TEMP, $fileline, $class );
  2207.  
  2208.                 # If there is no echoing occuring, it doesn't matter what we do to these
  2209.  
  2210.                 if ( $echo ) {
  2211.                     if ( $line =~ /^Subject:(.*)/i )  {
  2212.                         $msg_subject = $1;
  2213.                         $msg_subject =~ s/(\012|\015)//g;
  2214.                         next;
  2215.                     }
  2216.  
  2217.                     # Strip out the X-Text-Classification header that is in an incoming message
  2218.  
  2219.                     next if ( $line =~ /^X-Text-Classification:/i );
  2220.                     next if ( $line =~ /^X-POPFile-Link:/i );
  2221.  
  2222.                     # Store any lines that appear as though they may be non-header content
  2223.                     # Lines that are headers begin with whitespace or Alphanumerics and "-"
  2224.                     # followed by a colon.
  2225.                     #
  2226.                     # This prevents weird things like HTML before the headers terminate from
  2227.                     # causing the XPL and XTC headers to be inserted in places some clients
  2228.                     # can't detect
  2229.  
  2230.                     if ( $line =~ /^([ \t]|([A-Z\-_]+:))/i ) {
  2231.                         if ( !defined($msg_subject) )  {
  2232.                             $msg_head_before .= $msg_head_q . $line;
  2233.                         } else {
  2234.                             $msg_head_after  .= $msg_head_q . $line;
  2235.                         }
  2236.                         $msg_head_q = '';
  2237.                     } else {
  2238.  
  2239.                         # Gather up any header lines that are questionable
  2240.  
  2241.                         $self->log_( "Found odd email header: $line" );
  2242.                         $msg_head_q .= $line;
  2243.                     }
  2244.                 }
  2245.             } else {
  2246.                 $self->write_line__( $nosave?undef:\*TEMP, "\n", $class );
  2247.                 $message_size += length $crlf;
  2248.                 $getting_headers = 0;
  2249.             }
  2250.         } else {
  2251.             $message_size += length $line;
  2252.             $msg_body     .= $line;
  2253.             $self->write_line__( $nosave?undef:\*TEMP, $fileline, $class );
  2254.         }
  2255.  
  2256.         # Check to see if too much time has passed and we need to keep the mail client happy
  2257.         if ( time > ( $last_timeout + 2 ) ) {
  2258.             print $client "X-POPFile-TimeoutPrevention: $timeout_count$crlf" if ( $echo );
  2259.             $timeout_count += 1;
  2260.             $last_timeout = time;
  2261.         }
  2262.  
  2263.         last if ( ( $message_size > $self->global_config_( 'message_cutoff' ) ) && ( $getting_headers == 0 ) );
  2264.     }
  2265.  
  2266.     close TEMP unless $nosave;
  2267.  
  2268.     # If we don't yet know the classification then stop the parser
  2269.     if ( $class eq '' ) {
  2270.         $self->{parser__}->stop_parse();
  2271.     }
  2272.  
  2273.     # Do the text classification and update the counter for that bucket that we just downloaded
  2274.     # an email of that type
  2275.  
  2276.     if ( $self->module_config_( 'html', 'language' ) eq 'Nihongo' ) {
  2277.  
  2278.         # Parse Japanese mail message with Kakasi
  2279.  
  2280.         $self->parse_with_kakasi__( $temp_file, $dcount, $mcount );
  2281.  
  2282.         $classification = ($class ne '')?$class:$self->classify( $session, $temp_file);
  2283.     } else {
  2284.         $classification = ($class ne '')?$class:$self->classify( $session, undef);
  2285.     }
  2286.  
  2287.     my $subject_modification = $self->get_bucket_parameter( $session, $classification, 'subject'    );
  2288.     my $xtc_insertion        = $self->get_bucket_parameter( $session, $classification, 'xtc'        );
  2289.     my $xpl_insertion        = $self->get_bucket_parameter( $session, $classification, 'xpl'        );
  2290.     my $quarantine           = $self->get_bucket_parameter( $session, $classification, 'quarantine' );
  2291.  
  2292.     my $modification = $self->config_( 'subject_mod_left' ) . $classification . $self->config_( 'subject_mod_right' );
  2293.  
  2294.     # Add the Subject line modification or the original line back again
  2295.     # Don't add the classification unless it is not present
  2296.     if (  ( defined( $msg_subject ) && ( $msg_subject !~ /\Q$modification\E/ ) ) && # PROFILE BLOCK START
  2297.           ( $subject_modification == 1 ) &&
  2298.           ( $quarantine == 0 ) )  {                                                 # PROFILE BLOCK STOP
  2299.          $msg_subject = " $modification$msg_subject";
  2300.     }
  2301.  
  2302.     if ( !defined( $msg_subject )       &&                                         # PROFILE BLOCK START
  2303.          ( $subject_modification == 1 ) &&
  2304.          ( $quarantine == 0 ) )  {                                                 # PROFILE BLOCK STOP
  2305.          $msg_subject = " $modification";
  2306.     }
  2307.  
  2308.     $msg_subject = '' if ( !defined( $msg_subject ) );
  2309.  
  2310.     $msg_head_before .= 'Subject:' . $msg_subject;
  2311.     $msg_head_before .= $crlf;
  2312.  
  2313.     # Add the XTC header
  2314.     $msg_head_after .= "X-Text-Classification: $classification$crlf" if ( ( $xtc_insertion   ) && # PROFILE BLOCK START
  2315.                                                                           ( $quarantine == 0 ) ); # PROFILE BLOCK STOP
  2316.  
  2317.     # Add the XPL header
  2318.     my $xpl = '';
  2319.  
  2320.     $xpl .= "http://";
  2321.     $xpl .= $self->module_config_( 'html', 'local' )?"127.0.0.1":$self->config_( 'hostname' );
  2322.     $xpl .= ":" . $self->module_config_( 'html', 'port' ) . "/jump_to_message?view=$nopath_temp_file$crlf";
  2323.  
  2324.     if ( $xpl_insertion && ( $quarantine == 0 ) ) {
  2325.         $msg_head_after .= 'X-POPFile-Link: ' . $xpl;
  2326.     }
  2327.  
  2328.     $msg_head_after .= $msg_head_q . "$crlf";
  2329.  
  2330.     # Echo the text of the message to the client
  2331.  
  2332.     if ( $echo ) {
  2333.  
  2334.         # If the bucket is quarantined then we'll treat it specially by changing the message header to contain
  2335.         # information from POPFile and wrapping the original message in a MIME encoding
  2336.  
  2337.        if ( $quarantine == 1 ) {
  2338.            print $client "From: " . $self->{parser__}->get_header( 'from' ) . "$crlf";
  2339.            print $client "To: " . $self->{parser__}->get_header( 'to' ) . "$crlf";
  2340.            print $client "Date: " . $self->{parser__}->get_header( 'date' ) . "$crlf";
  2341.            # Don't add the classification unless it is not present
  2342.            if ( ( defined( $msg_subject ) && ( $msg_subject !~ /\[\Q$classification\E\]/ ) ) && # PROFILE BLOCK START
  2343.                  ( $subject_modification == 1 ) ) {                                             # PROFILE BLOCK STOP
  2344.                $msg_subject = " $modification$msg_subject";
  2345.            }
  2346.            print $client "Subject:$msg_subject$crlf";
  2347.            print $client "X-Text-Classification: $classification$crlf" if ( $xtc_insertion );
  2348.            print $client 'X-POPFile-Link: ' . $xpl if ( $xpl_insertion );
  2349.            print $client "MIME-Version: 1.0$crlf";
  2350.            print $client "Content-Type: multipart/report; boundary=\"$nopath_temp_file\"$crlf$crlf--$nopath_temp_file$crlf";
  2351.            print $client "Content-Type: text/plain$crlf$crlf";
  2352.            print $client "POPFile has quarantined a message.  It is attached to this email.$crlf$crlf";
  2353.            print $client "Quarantined Message Detail$crlf$crlf";
  2354.            print $client "Original From: " . $self->{parser__}->get_header('from') . "$crlf";
  2355.            print $client "Original To: " . $self->{parser__}->get_header('to') . "$crlf";
  2356.            print $client "Original Subject: " . $self->{parser__}->get_header('subject') . "$crlf";
  2357.            print $client "To examine the email open the attachment. ";
  2358.            print $client "To change this mail's classification go to $xpl";
  2359.            print $client "$crlf";
  2360.            print $client "The first 20 words found in the email are:$crlf$crlf";
  2361.            print $client $self->{parser__}->first20();
  2362.            print $client "$crlf--$nopath_temp_file$crlf";
  2363.            print $client "Content-Type: message/rfc822$crlf$crlf";
  2364.         }
  2365.  
  2366.         print $client $msg_head_before;
  2367.         print $client $msg_head_after;
  2368.         print $client $msg_body;
  2369.     }
  2370.  
  2371.     my $before_dot = '';
  2372.  
  2373.     if ( $quarantine && $echo ) {
  2374.         $before_dot = "$crlf--$nopath_temp_file--$crlf";
  2375.     }
  2376.  
  2377.     my $need_dot = 0;
  2378.  
  2379.     if ( $got_full_body ) {
  2380.         $need_dot = 1;
  2381.     } else {
  2382.         $need_dot = !$self->echo_to_dot_( $mail, $echo?$client:undef, $nosave?undef:'>>' . $temp_file, $before_dot ) && !$nosave;
  2383.     }
  2384.  
  2385.     if ( $need_dot ) {
  2386.         print $client $before_dot if ( $before_dot ne '' );
  2387.         print $client ".$crlf"    if ( $echo );
  2388.     }
  2389.  
  2390.     # In some cases it's possible (and totally illegal) to get a . in the middle of the message,
  2391.     # to cope with the we call flush_extra_ here to remove any extra stuff the POP3 server is sending
  2392.     # Make sure to supress output if we are not echoing, and to save to file if not echoing and saving
  2393.  
  2394.     if ( !($nosave || $echo) ) {
  2395.  
  2396.         # if we're saving (not nosave) and not echoing, we can safely unload this into the temp file
  2397.  
  2398.         if (open FLUSH, ">$temp_file.flush") {
  2399.             binmode FLUSH;
  2400.  
  2401.             # TODO: Do this in a faster way (without flushing to one file then copying to another)
  2402.             # (perhaps a select on $mail to predict if there is flushable data)
  2403.  
  2404.             $self->flush_extra_( $mail, \*FLUSH, 0);
  2405.             close FLUSH;
  2406.  
  2407.             # append any data we got to the actual temp file
  2408.  
  2409.             if ( ( (-s "$temp_file.flush") > 0 ) && ( open FLUSH, "<$temp_file.flush" ) ) {
  2410.                 binmode FLUSH;
  2411.                 if ( open TEMP, ">>$temp_file" ) {
  2412.                     binmode TEMP;
  2413.  
  2414.                     # The only time we get data here is if it is after a CRLF.CRLF
  2415.                     # We have to re-create it to avoid data-loss
  2416.  
  2417.                     print TEMP ".$crlf";
  2418.  
  2419.                     print TEMP $_ while (<FLUSH>);
  2420.  
  2421.                     # NOTE: The last line flushed MAY be a CRLF.CRLF, which isn't actually part of the message body
  2422.  
  2423.                     close TEMP;
  2424.                 }
  2425.                 close FLUSH;
  2426.             }
  2427.             unlink("$temp_file.flush");
  2428.         }
  2429.     } else {
  2430.  
  2431.         # if we are echoing, the client can make sure we have no data loss
  2432.         # otherwise, the data can be discarded (not saved and not echoed)
  2433.  
  2434.         $self->flush_extra_( $mail, $client, $echo?0:1);
  2435.     }
  2436.  
  2437.     if ( !$nosave ) {
  2438.         $self->history_write_class($class_file, undef, $classification, undef, ($self->{magnet_used__}?$self->{magnet_detail__}:undef));
  2439.  
  2440.         # Now rename the MSG file, since the class file has been written it's safe for the mesg
  2441.         # file to have the correct name.  If the history cache is reloaded then we wont have a class
  2442.         # file error since it was already written
  2443.  
  2444.         unlink $msg_file;
  2445.         rename $temp_file, $msg_file;
  2446.     }
  2447.  
  2448.     return ( $classification, $nopath_temp_file );
  2449. }
  2450.  
  2451. # ---------------------------------------------------------------------------------------------
  2452. #
  2453. # get_buckets
  2454. #
  2455. # Returns a list containing all the real bucket names sorted into alphabetic order
  2456. #
  2457. # $session   A valid session key returned by a call to get_session_key
  2458. #
  2459. # ---------------------------------------------------------------------------------------------
  2460. sub get_buckets
  2461. {
  2462.     my ( $self, $session ) = @_;
  2463.  
  2464.     my $userid = $self->valid_session_key__( $session );
  2465.     return undef if ( !defined( $userid ) );
  2466.  
  2467.     # Note that get_buckets does not return pseudo buckets
  2468.  
  2469.     my @buckets;
  2470.  
  2471.     for my $b (sort keys %{$self->{db_bucketid__}{$userid}}) {
  2472.         if ( $self->{db_bucketid__}{$userid}{$b}{pseudo} == 0 ) {
  2473.             push @buckets, ($b);
  2474.     }
  2475.     }
  2476.  
  2477.     return @buckets;
  2478. }
  2479.  
  2480. # ---------------------------------------------------------------------------------------------
  2481. #
  2482. # get_pseudo_buckets
  2483. #
  2484. # Returns a list containing all the pseudo bucket names sorted into alphabetic order
  2485. #
  2486. # $session   A valid session key returned by a call to get_session_key
  2487. #
  2488. # ---------------------------------------------------------------------------------------------
  2489. sub get_pseudo_buckets
  2490. {
  2491.     my ( $self, $session ) = @_;
  2492.  
  2493.     my $userid = $self->valid_session_key__( $session );
  2494.     return undef if ( !defined( $userid ) );
  2495.  
  2496.     my @buckets;
  2497.  
  2498.     for my $b (sort keys %{$self->{db_bucketid__}{$userid}}) {
  2499.         if ( $self->{db_bucketid__}{$userid}{$b}{pseudo} == 1 ) {
  2500.             push @buckets, ($b);
  2501.     }
  2502.     }
  2503.  
  2504.     return @buckets;
  2505. }
  2506.  
  2507. # ---------------------------------------------------------------------------------------------
  2508. #
  2509. # get_all_buckets
  2510. #
  2511. # Returns a list containing all the bucket names sorted into alphabetic order
  2512. #
  2513. # $session   A valid session key returned by a call to get_session_key
  2514. #
  2515. # ---------------------------------------------------------------------------------------------
  2516. sub get_all_buckets
  2517. {
  2518.     my ( $self, $session ) = @_;
  2519.  
  2520.     my $userid = $self->valid_session_key__( $session );
  2521.     return undef if ( !defined( $userid ) );
  2522.  
  2523.     my @buckets;
  2524.  
  2525.     for my $b (sort keys %{$self->{db_bucketid__}{$userid}}) {
  2526.          push @buckets, ($b);
  2527.     }
  2528.  
  2529.     return @buckets;
  2530. }
  2531.  
  2532. # ---------------------------------------------------------------------------------------------
  2533. #
  2534. # is_pseudo_bucket
  2535. #
  2536. # Returns 1 if the named bucket is pseudo
  2537. #
  2538. # $session   A valid session key returned by a call to get_session_key
  2539. # $bucket    The bucket to check
  2540. #
  2541. # ---------------------------------------------------------------------------------------------
  2542. sub is_pseudo_bucket
  2543. {
  2544.     my ( $self, $session, $bucket ) = @_;
  2545.  
  2546.     my $userid = $self->valid_session_key__( $session );
  2547.     return undef if ( !defined( $userid ) );
  2548.  
  2549.     return ( defined($self->{db_bucketid__}{$userid}{$bucket})   # PROFILE BLOCK START
  2550.           && $self->{db_bucketid__}{$userid}{$bucket}{pseudo} ); # PROFILE BLOCK STOP
  2551. }
  2552.  
  2553. # ---------------------------------------------------------------------------------------------
  2554. #
  2555. # is_bucket
  2556. #
  2557. # Returns 1 if the named bucket is a bucket
  2558. #
  2559. # $session   A valid session key returned by a call to get_session_key
  2560. # $bucket    The bucket to check
  2561. #
  2562. # ---------------------------------------------------------------------------------------------
  2563. sub is_bucket
  2564. {
  2565.     my ( $self, $session, $bucket ) = @_;
  2566.  
  2567.     my $userid = $self->valid_session_key__( $session );
  2568.     return undef if ( !defined( $userid ) );
  2569.  
  2570.     return ( ( defined( $self->{db_bucketid__}{$userid}{$bucket} ) ) &&  # PROFILE BLOCK START
  2571.              ( !$self->{db_bucketid__}{$userid}{$bucket}{pseudo} ) );    # PROFILE BLOCK STOP
  2572. }
  2573.  
  2574. # ---------------------------------------------------------------------------------------------
  2575. #
  2576. # get_bucket_word_count
  2577. #
  2578. # Returns the total word count (including duplicates) for the passed in bucket
  2579. #
  2580. # $session     A valid session key returned by a call to get_session_key
  2581. # $bucket      The name of the bucket for which the word count is desired
  2582. #
  2583. # ---------------------------------------------------------------------------------------------
  2584. sub get_bucket_word_count
  2585. {
  2586.     my ( $self, $session, $bucket ) = @_;
  2587.  
  2588.     my $userid = $self->valid_session_key__( $session );
  2589.     return undef if ( !defined( $userid ) );
  2590.  
  2591.     my $c = $self->{db_bucketcount__}{$userid}{$bucket};
  2592.  
  2593.     return defined($c)?$c:0;
  2594. }
  2595.  
  2596. # ---------------------------------------------------------------------------------------------
  2597. #
  2598. # get_bucket_word_list
  2599. #
  2600. # Returns a list of words all with the same first character
  2601. #
  2602. # $session     A valid session key returned by a call to get_session_key
  2603. # $bucket      The name of the bucket for which the word count is desired
  2604. # $prefix      The first character of the words
  2605. #
  2606. # ---------------------------------------------------------------------------------------------
  2607. sub get_bucket_word_list
  2608. {
  2609.     my ( $self, $session, $bucket, $prefix ) = @_;
  2610.  
  2611.     my $userid = $self->valid_session_key__( $session );
  2612.     return undef if ( !defined( $userid ) );
  2613.  
  2614.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  2615.     my $result = $self->{db__}->selectcol_arrayref(  # PROFILE BLOCK START
  2616.         "select words.word from matrix, words
  2617.          where matrix.wordid  = words.id and
  2618.                matrix.bucketid = $bucketid and
  2619.                words.word like '$prefix%';");        # PROFILE BLOCK STOP
  2620.  
  2621.     return @{$result};
  2622. }
  2623.  
  2624. # ---------------------------------------------------------------------------------------------
  2625. #
  2626. # get_bucket_word_prefixes
  2627. #
  2628. # Returns a list of all the initial letters of words in a bucket
  2629. #
  2630. # $session     A valid session key returned by a call to get_session_key
  2631. # $bucket      The name of the bucket for which the word count is desired
  2632. #
  2633. # ---------------------------------------------------------------------------------------------
  2634. sub get_bucket_word_prefixes
  2635. {
  2636.     my ( $self, $session, $bucket ) = @_;
  2637.  
  2638.     my $userid = $self->valid_session_key__( $session );
  2639.     return undef if ( !defined( $userid ) );
  2640.  
  2641.     my $prev = '';
  2642.  
  2643.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  2644.     my $result = $self->{db__}->selectcol_arrayref(   # PROFILE BLOCK START
  2645.         "select words.word from matrix, words
  2646.          where matrix.wordid  = words.id and
  2647.                matrix.bucketid = $bucketid;");        # PROFILE BLOCK STOP
  2648.  
  2649.     # In Japanese mode, disable locale and use substr_euc, the substr function
  2650.     # which supports EUC Japanese charset.
  2651.     # Sorting Japanese with "use locale" is memory and time consuming,
  2652.     # and may cause perl crash.
  2653.  
  2654.     if ( $self->module_config_( 'html', 'language' ) eq 'Nihongo' ) {
  2655.         no locale;
  2656.         return grep {$_ ne $prev && ($prev = $_, 1)} sort map {substr_euc__($_,0,1)} @{$result};
  2657.     } else {
  2658.         if  ( $self->module_config_( 'html', 'language' ) eq 'Korean' ) {
  2659.             no locale;
  2660.             return grep {$_ ne $prev && ($prev = $_, 1)} sort map {$_ =~ /([\x20-\x80]|$eksc)/} @{$result};
  2661.         } else {
  2662.             return grep {$_ ne $prev && ($prev = $_, 1)} sort map {substr($_,0,1)}  @{$result};
  2663.         }
  2664.     }
  2665. }
  2666.  
  2667. # ---------------------------------------------------------------------------------------------
  2668. #
  2669. # get_word_count
  2670. #
  2671. # Returns the total word count (including duplicates)
  2672. #
  2673. # $session   A valid session key returned by a call to get_session_key
  2674. #
  2675. # ---------------------------------------------------------------------------------------------
  2676. sub get_word_count
  2677. {
  2678.     my ( $self, $session ) = @_;
  2679.  
  2680.     my $userid = $self->valid_session_key__( $session );
  2681.     return undef if ( !defined( $userid ) );
  2682.  
  2683.     $self->{db_get_full_total__}->execute( $userid );
  2684.     return $self->{db_get_full_total__}->fetchrow_arrayref->[0];
  2685. }
  2686.  
  2687. # ---------------------------------------------------------------------------------------------
  2688. #
  2689. # get_count_for_word
  2690. #
  2691. # Returns the number of times the word occurs in a bucket
  2692. #
  2693. # $session         A valid session key returned by a call to get_session_key
  2694. # $bucket          The bucket we are asking about
  2695. # $word            The word we are asking about
  2696. #
  2697. # ---------------------------------------------------------------------------------------------
  2698. sub get_count_for_word
  2699. {
  2700.     my ( $self, $session, $bucket, $word ) = @_;
  2701.  
  2702.     my $userid = $self->valid_session_key__( $session );
  2703.     return undef if ( !defined( $userid ) );
  2704.  
  2705.     return $self->get_base_value_( $session, $bucket, $word );
  2706. }
  2707.  
  2708. # ---------------------------------------------------------------------------------------------
  2709. #
  2710. # get_bucket_unique_count
  2711. #
  2712. # Returns the unique word count (excluding duplicates) for the passed in bucket
  2713. #
  2714. # $session     A valid session key returned by a call to get_session_key
  2715. # $bucket      The name of the bucket for which the word count is desired
  2716. #
  2717. # ---------------------------------------------------------------------------------------------
  2718. sub get_bucket_unique_count
  2719. {
  2720.     my ( $self, $session, $bucket ) = @_;
  2721.  
  2722.     my $userid = $self->valid_session_key__( $session );
  2723.     return undef if ( !defined( $userid ) );
  2724.  
  2725.     my $c = $self->{db_bucketunique__}{$userid}{$bucket};
  2726.  
  2727.     return defined($c)?$c:0;
  2728. }
  2729.  
  2730. # ---------------------------------------------------------------------------------------------
  2731. #
  2732. # get_unique_word_count
  2733. #
  2734. # Returns the unique word count (excluding duplicates) for all buckets
  2735. #
  2736. # $session   A valid session key returned by a call to get_session_key
  2737. #
  2738. # ---------------------------------------------------------------------------------------------
  2739. sub get_unique_word_count
  2740. {
  2741.     my ( $self, $session ) = @_;
  2742.  
  2743.     my $userid = $self->valid_session_key__( $session );
  2744.     return undef if ( !defined( $userid ) );
  2745.  
  2746.     $self->{db_get_unique_word_count__}->execute( $userid );
  2747.     return $self->{db_get_unique_word_count__}->fetchrow_arrayref->[0];
  2748. }
  2749.  
  2750. # ---------------------------------------------------------------------------------------------
  2751. #
  2752. # get_bucket_color
  2753. #
  2754. # Returns the color associated with a bucket
  2755. #
  2756. # $session   A valid session key returned by a call to get_session_key
  2757. # $bucket      The name of the bucket for which the color is requested
  2758. #
  2759. # NOTE  This API is DEPRECATED in favor of calling get_bucket_parameter for
  2760. #       the parameter named 'color'
  2761. # ---------------------------------------------------------------------------------------------
  2762. sub get_bucket_color
  2763. {
  2764.     my ( $self, $session, $bucket ) = @_;
  2765.  
  2766.     return $self->get_bucket_parameter( $session, $bucket, 'color' );
  2767. }
  2768.  
  2769. # ---------------------------------------------------------------------------------------------
  2770. #
  2771. # set_bucket_color
  2772. #
  2773. # Returns the color associated with a bucket
  2774. #
  2775. # $session     A valid session key returned by a call to get_session_key
  2776. # $bucket      The name of the bucket for which the color is requested
  2777. # $color       The new color
  2778. #
  2779. # NOTE  This API is DEPRECATED in favor of calling set_bucket_parameter for
  2780. #       the parameter named 'color'
  2781. # ---------------------------------------------------------------------------------------------
  2782. sub set_bucket_color
  2783. {
  2784.     my ( $self, $session, $bucket, $color ) = @_;
  2785.  
  2786.     return $self->set_bucket_parameter( $session, $bucket, 'color', $color );
  2787. }
  2788.  
  2789. # ---------------------------------------------------------------------------------------------
  2790. #
  2791. # get_bucket_parameter
  2792. #
  2793. # Returns the value of a per bucket parameter
  2794. #
  2795. # $session     A valid session key returned by a call to get_session_key
  2796. # $bucket      The name of the bucket
  2797. # $parameter   The name of the parameter
  2798. #
  2799. # ---------------------------------------------------------------------------------------------
  2800. sub get_bucket_parameter
  2801. {
  2802.     my ( $self, $session, $bucket, $parameter ) = @_;
  2803.  
  2804.     my $userid = $self->valid_session_key__( $session );
  2805.     return undef if ( !defined( $userid ) );
  2806.  
  2807.     # See if there's a cached value
  2808.  
  2809.     if ( defined( $self->{db_parameters__}{$userid}{$bucket}{$parameter} ) ) {
  2810.         return $self->{db_parameters__}{$userid}{$bucket}{$parameter};
  2811.     }
  2812.  
  2813.     # Make sure that the bucket passed in actually exists
  2814.  
  2815.     if ( !defined( $self->{db_bucketid__}{$userid}{$bucket} ) ) {
  2816.         return undef;
  2817.     }
  2818.  
  2819.     # If there is a non-default value for this parameter then return it.
  2820.  
  2821.     $self->{db_get_bucket_parameter__}->execute( $self->{db_bucketid__}{$userid}{$bucket}{id}, $self->{db_parameterid__}{$parameter} );
  2822.     my $result = $self->{db_get_bucket_parameter__}->fetchrow_arrayref;
  2823.  
  2824.     # If this parameter has not been defined for this specific bucket then
  2825.     # get the default value
  2826.  
  2827.     if ( !defined( $result ) ) {
  2828.         $self->{db_get_bucket_parameter_default__}->execute(  # PROFILE BLOCK START
  2829.             $self->{db_parameterid__}{$parameter} );          # PROFILE BLOCK STOP
  2830.         $result = $self->{db_get_bucket_parameter_default__}->fetchrow_arrayref;
  2831.     }
  2832.  
  2833.     if ( defined( $result ) ) {
  2834.         $self->{db_parameters__}{$userid}{$bucket}{$parameter} = $result->[0];
  2835.         return $result->[0];
  2836.     } else {
  2837.         return undef;
  2838.     }
  2839. }
  2840.  
  2841. # ---------------------------------------------------------------------------------------------
  2842. #
  2843. # set_bucket_parameter
  2844. #
  2845. # Sets the value associated with a bucket specific parameter
  2846. #
  2847. # $session     A valid session key returned by a call to get_session_key
  2848. # $bucket      The name of the bucket
  2849. # $parameter   The name of the parameter
  2850. # $value       The new value
  2851. #
  2852. # ---------------------------------------------------------------------------------------------
  2853. sub set_bucket_parameter
  2854. {
  2855.     my ( $self, $session, $bucket, $parameter, $value ) = @_;
  2856.  
  2857.     my $userid = $self->valid_session_key__( $session );
  2858.     return undef if ( !defined( $userid ) );
  2859.  
  2860.     # Make sure that the bucket passed in actually exists
  2861.  
  2862.     if ( !defined( $self->{db_bucketid__}{$userid}{$bucket} ) ) {
  2863.         return undef;
  2864.     }
  2865.  
  2866.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  2867.     my $btid     = $self->{db_parameterid__}{$parameter};
  2868.  
  2869.     # Exactly one row should be affected by this statement
  2870.  
  2871.     $self->{db_set_bucket_parameter__}->execute( $bucketid, $btid, $value );
  2872.  
  2873.     if ( defined( $self->{db_parameters__}{$userid}{$bucket}{$parameter} ) ) {
  2874.         $self->{db_parameters__}{$userid}{$bucket}{$parameter} = $value;
  2875.     }
  2876.  
  2877.     return 1;
  2878. }
  2879.  
  2880. # ---------------------------------------------------------------------------------------------
  2881. #
  2882. # get_html_colored_message
  2883. #
  2884. # Parser a mail message stored in a file and returns HTML representing the message
  2885. # with coloring of the words
  2886. #
  2887. # $session        A valid session key returned by a call to get_session_key
  2888. # $file           The file to parse
  2889. #
  2890. # ---------------------------------------------------------------------------------------------
  2891. sub get_html_colored_message
  2892. {
  2893.     my ( $self, $session, $file ) = @_;
  2894.  
  2895.     my $userid = $self->valid_session_key__( $session );
  2896.     return undef if ( !defined( $userid ) );
  2897.  
  2898.     $self->{parser__}->{color__} = $session;
  2899.     $self->{parser__}->{color_matrix__} = undef;
  2900.     $self->{parser__}->{color_idmap__}  = undef;
  2901.     $self->{parser__}->{color_userid__} = undef;
  2902.     $self->{parser__}->{bayes__} = bless $self;
  2903.  
  2904.     # Pass language parameter to parse_file()
  2905.  
  2906.     my $result = $self->{parser__}->parse_file( $file,   # PROFILE BLOCK START                     
  2907.           $self->module_config_( 'html', 'language' ),
  2908.           $self->global_config_( 'message_cutoff'   ) ); # PROFILE BLOCK STOP
  2909.  
  2910.     $self->{parser__}->{color__} = '';
  2911.  
  2912.     return $result;
  2913. }
  2914.  
  2915. # ---------------------------------------------------------------------------------------------
  2916. #
  2917. # fast_get_html_colored_message
  2918. #
  2919. # Parser a mail message stored in a file and returns HTML representing the message
  2920. # with coloring of the words
  2921. #
  2922. # $session        A valid session key returned by a call to get_session_key
  2923. # $file           The file to colorize
  2924. # $matrix         Reference to the matrix hash from a call to classify
  2925. # $idmap          Reference to the idmap hash from a call to classify
  2926. #
  2927. # ---------------------------------------------------------------------------------------------
  2928. sub fast_get_html_colored_message
  2929. {
  2930.     my ( $self, $session, $file, $matrix, $idmap ) = @_;
  2931.  
  2932.     my $userid = $self->valid_session_key__( $session );
  2933.     return undef if ( !defined( $userid ) );
  2934.  
  2935.     $self->{parser__}->{color__}        = $session;
  2936.     $self->{parser__}->{color_matrix__} = $matrix;
  2937.     $self->{parser__}->{color_idmap__}  = $idmap;
  2938.     $self->{parser__}->{color_userid__} = $userid;
  2939.     $self->{parser__}->{bayes__}        = bless $self;
  2940.  
  2941.     # Pass language parameter to parse_file()
  2942.  
  2943.     my $result = $self->{parser__}->parse_file( $file,
  2944.                                                 $self->module_config_( 'html', 'language' ),
  2945.                                                 $self->global_config_( 'message_cutoff'   ) );
  2946.  
  2947.     $self->{parser__}->{color__} = '';
  2948.  
  2949.     return $result;
  2950. }
  2951.  
  2952. # ---------------------------------------------------------------------------------------------
  2953. #
  2954. # create_bucket
  2955. #
  2956. # Creates a new bucket, returns 1 if the creation succeeded
  2957. #
  2958. # $session     A valid session key returned by a call to get_session_key
  2959. # $bucket      Name for the new bucket
  2960. #
  2961. # ---------------------------------------------------------------------------------------------
  2962. sub create_bucket
  2963. {
  2964.     my ( $self, $session, $bucket ) = @_;
  2965.  
  2966.     if ( $self->is_bucket( $session, $bucket ) ||           # PROFILE BLOCK START
  2967.          $self->is_pseudo_bucket( $session, $bucket ) ) {   # PROFILE BLOCK STOP
  2968.         return 0;
  2969.     }
  2970.  
  2971.     my $userid = $self->valid_session_key__( $session );
  2972.     return undef if ( !defined( $userid ) );
  2973.  
  2974.     $bucket = $self->{db__}->quote( $bucket );
  2975.  
  2976.     $self->{db__}->do(                                                                    # PROFILE BLOCK START
  2977.         "insert into buckets ( name, pseudo, userid ) values ( $bucket, 0, $userid );" ); # PROFILE BLOCK STOP
  2978.     $self->db_update_cache__( $session );
  2979.  
  2980.     return 1;
  2981. }
  2982.  
  2983. # ---------------------------------------------------------------------------------------------
  2984. #
  2985. # delete_bucket
  2986. #
  2987. # Deletes a bucket, returns 1 if the delete succeeded
  2988. #
  2989. # $session     A valid session key returned by a call to get_session_key
  2990. # $bucket      Name of the bucket to delete
  2991. #
  2992. # ---------------------------------------------------------------------------------------------
  2993. sub delete_bucket
  2994. {
  2995.     my ( $self, $session, $bucket ) = @_;
  2996.  
  2997.     my $userid = $self->valid_session_key__( $session );
  2998.     return undef if ( !defined( $userid ) );
  2999.  
  3000.     # Make sure that the bucket passed in actually exists
  3001.  
  3002.     if ( !defined( $self->{db_bucketid__}{$userid}{$bucket} ) ) {
  3003.         return 0;
  3004.     }
  3005.  
  3006.     $self->{db__}->do(                                                                        # PROFILE BLOCK START
  3007.         "delete from buckets where buckets.userid = $userid and buckets.name = '$bucket';" ); # PROFILE BLOCK STOP
  3008.     $self->db_update_cache__( $session );
  3009.  
  3010.     return 1;
  3011. }
  3012.  
  3013. # ---------------------------------------------------------------------------------------------
  3014. #
  3015. # rename_bucket
  3016. #
  3017. # Renames a bucket, returns 1 if the rename succeeded
  3018. #
  3019. # $session             A valid session key returned by a call to get_session_key
  3020. # $old_bucket          The old name of the bucket
  3021. # $new_bucket          The new name of the bucket
  3022. #
  3023. # ---------------------------------------------------------------------------------------------
  3024. sub rename_bucket
  3025. {
  3026.     my ( $self, $session, $old_bucket, $new_bucket ) = @_;
  3027.  
  3028.     my $userid = $self->valid_session_key__( $session );
  3029.     return undef if ( !defined( $userid ) );
  3030.  
  3031.     # Make sure that the bucket passed in actually exists
  3032.  
  3033.     if ( !defined( $self->{db_bucketid__}{$userid}{$old_bucket} ) ) {
  3034.         $self->log_( "Bad bucket name $old_bucket to rename_bucket" );
  3035.         return 0;
  3036.     }
  3037.  
  3038.     my $id = $self->{db__}->quote( $self->{db_bucketid__}{$userid}{$old_bucket}{id} );
  3039.     $new_bucket = $self->{db__}->quote( $new_bucket );
  3040.  
  3041.     $self->log_( "Rename bucket $old_bucket to $new_bucket" );
  3042.  
  3043.     my $result = $self->{db__}->do( "update buckets set name = $new_bucket where id = $id;" );
  3044.  
  3045.     if ( !defined( $result ) || ( $result == -1 ) ) {
  3046.         return 0;
  3047.     } else {
  3048.         $self->db_update_cache__( $session );
  3049.         return 1;
  3050.     }
  3051. }
  3052.  
  3053. # ---------------------------------------------------------------------------------------------
  3054. #
  3055. # add_messages_to_bucket
  3056. #
  3057. # Parses mail messages and updates the statistics in the specified bucket
  3058. #
  3059. # $session         A valid session key returned by a call to get_session_key
  3060. # $bucket          Name of the bucket to be updated
  3061. # @files           List of file names to parse
  3062. #
  3063. # ---------------------------------------------------------------------------------------------
  3064. sub add_messages_to_bucket
  3065. {
  3066.     my ( $self, $session, $bucket, @files ) = @_;
  3067.  
  3068.     my $userid = $self->valid_session_key__( $session );
  3069.     return undef if ( !defined( $userid ) );
  3070.  
  3071.     if ( !defined( $self->{db_bucketid__}{$userid}{$bucket}{id} ) ) {
  3072.         return 0;
  3073.     }
  3074.  
  3075.     # Pass language parameter to parse_file()
  3076.  
  3077.     # This is done to clear out the word list because in the loop
  3078.     # below we are going to not reset the word list on each parse
  3079.  
  3080.     $self->{parser__}->start_parse();
  3081.     $self->{parser__}->stop_parse();
  3082.  
  3083.     foreach my $file (@files) {
  3084.         $self->{parser__}->parse_file( $file,  # PROFILE BLOCK START
  3085.             $self->module_config_( 'html', 'language' ),
  3086.             $self->global_config_( 'message_cutoff'   ),
  3087.             0 );  # PROFILE BLOCK STOP (Do not reset word list)
  3088.     }
  3089.  
  3090.     $self->add_words_to_bucket__( $session, $bucket, 1 );
  3091.     $self->db_update_cache__( $session );
  3092.  
  3093.     return 1;
  3094. }
  3095.  
  3096. # ---------------------------------------------------------------------------------------------
  3097. #
  3098. # add_message_to_bucket
  3099. #
  3100. # Parses a mail message and updates the statistics in the specified bucket
  3101. #
  3102. # $session         A valid session key returned by a call to get_session_key
  3103. # $bucket          Name of the bucket to be updated
  3104. # $file            Name of file containing mail message to parse
  3105. #
  3106. # ---------------------------------------------------------------------------------------------
  3107. sub add_message_to_bucket
  3108. {
  3109.     my ( $self, $session, $bucket, $file ) = @_;
  3110.  
  3111.     my $userid = $self->valid_session_key__( $session );
  3112.     return undef if ( !defined( $userid ) );
  3113.  
  3114.     return $self->add_messages_to_bucket( $session, $bucket, $file );
  3115. }
  3116.  
  3117. # ---------------------------------------------------------------------------------------------
  3118. #
  3119. # remove_message_from_bucket
  3120. #
  3121. # Parses a mail message and updates the statistics in the specified bucket
  3122. #
  3123. # $session         A valid session key returned by a call to get_session_key
  3124. # $bucket          Name of the bucket to be updated
  3125. # $file            Name of file containing mail message to parse
  3126. #
  3127. # ---------------------------------------------------------------------------------------------
  3128. sub remove_message_from_bucket
  3129. {
  3130.     my ( $self, $session, $bucket, $file ) = @_;
  3131.  
  3132.     my $userid = $self->valid_session_key__( $session );
  3133.     return undef if ( !defined( $userid ) );
  3134.  
  3135.     # Pass language parameter to parse_file()
  3136.  
  3137.     $self->{parser__}->parse_file( $file,               # PROFILE BLOCK START
  3138.          $self->module_config_( 'html', 'language' ),
  3139.          $self->global_config_( 'message_cutoff'   ) ); # PROFILE BLOCK STOP
  3140.     $self->add_words_to_bucket__( $session, $bucket, -1 );
  3141.  
  3142.     $self->db_update_cache__( $session );
  3143.  
  3144.     return 1;
  3145. }
  3146.  
  3147. # ---------------------------------------------------------------------------------------------
  3148. #
  3149. # get_buckets_with_magnets
  3150. #
  3151. # Returns the names of the buckets for which magnets are defined
  3152. #
  3153. # $session     A valid session key returned by a call to get_session_key
  3154. #
  3155. # ---------------------------------------------------------------------------------------------
  3156. sub get_buckets_with_magnets
  3157. {
  3158.     my ( $self, $session ) = @_;
  3159.  
  3160.     my $userid = $self->valid_session_key__( $session );
  3161.     return undef if ( !defined( $userid ) );
  3162.  
  3163.     my @result;
  3164.  
  3165.     $self->{db_get_buckets_with_magnets__}->execute( $userid );
  3166.     while ( my $row = $self->{db_get_buckets_with_magnets__}->fetchrow_arrayref ) {
  3167.         push @result, ($row->[0]);
  3168.     }
  3169.  
  3170.     return @result;
  3171. }
  3172.  
  3173. # ---------------------------------------------------------------------------------------------
  3174. #
  3175. # get_magnet_types_in_bucket
  3176. #
  3177. # Returns the types of the magnets in a specific bucket
  3178. #
  3179. # $session     A valid session key returned by a call to get_session_key
  3180. # $bucket      The bucket to search for magnets
  3181. #
  3182. # ---------------------------------------------------------------------------------------------
  3183. sub get_magnet_types_in_bucket
  3184. {
  3185.     my ( $self, $session, $bucket ) = @_;
  3186.  
  3187.     my $userid = $self->valid_session_key__( $session );
  3188.     return undef if ( !defined( $userid ) );
  3189.  
  3190.     my @result;
  3191.  
  3192.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  3193.     my $h = $self->{db__}->prepare( "select magnet_types.mtype from magnet_types, magnets, buckets
  3194.         where magnet_types.id = magnets.mtid and
  3195.               magnets.bucketid = buckets.id and
  3196.               buckets.id = $bucketid
  3197.               group by magnet_types.mtype
  3198.               order by magnet_types.mtype;" );
  3199.  
  3200.     $h->execute;
  3201.     while ( my $row = $h->fetchrow_arrayref ) {
  3202.         push @result, ($row->[0]);
  3203.     }
  3204.     $h->finish;
  3205.  
  3206.     return @result;
  3207. }
  3208.  
  3209. # ---------------------------------------------------------------------------------------------
  3210. #
  3211. # clear_bucket
  3212. #
  3213. # Removes all words from a bucket
  3214. #
  3215. # $session        A valid session key returned by a call to get_session_key
  3216. # $bucket         The bucket to clear
  3217. #
  3218. # ---------------------------------------------------------------------------------------------
  3219. sub clear_bucket
  3220. {
  3221.     my ( $self, $session, $bucket ) = @_;
  3222.  
  3223.     my $userid = $self->valid_session_key__( $session );
  3224.     return undef if ( !defined( $userid ) );
  3225.  
  3226.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  3227.  
  3228.     $self->{db__}->do( "delete from matrix where matrix.bucketid = $bucketid;" );
  3229.     $self->db_update_cache__( $session );
  3230. }
  3231.  
  3232. # ---------------------------------------------------------------------------------------------
  3233. #
  3234. # clear_magnets
  3235. #
  3236. # Removes every magnet currently defined
  3237. #
  3238. # $session     A valid session key returned by a call to get_session_key
  3239. #
  3240. # ---------------------------------------------------------------------------------------------
  3241. sub clear_magnets
  3242. {
  3243.     my ( $self, $session ) = @_;
  3244.  
  3245.     my $userid = $self->valid_session_key__( $session );
  3246.     return undef if ( !defined( $userid ) );
  3247.  
  3248.     for my $bucket (keys %{$self->{db_bucketid__}{$userid}}) {
  3249.         my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  3250.         $self->{db__}->do( "delete from magnets where magnets.bucketid = $bucketid" );
  3251.     }
  3252. }
  3253.  
  3254. # ---------------------------------------------------------------------------------------------
  3255. #
  3256. # get_magnets
  3257. #
  3258. # Returns the magnets of a certain type in a bucket
  3259. #
  3260. # $session         A valid session key returned by a call to get_session_key
  3261. # $bucket          The bucket to search for magnets
  3262. # $type            The magnet type (e.g. from, to or subject)
  3263. #
  3264. # ---------------------------------------------------------------------------------------------
  3265. sub get_magnets
  3266. {
  3267.     my ( $self, $session, $bucket, $type ) = @_;
  3268.  
  3269.     my $userid = $self->valid_session_key__( $session );
  3270.     return undef if ( !defined( $userid ) );
  3271.  
  3272.     my @result;
  3273.  
  3274.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  3275.     my $h = $self->{db__}->prepare( "select magnets.val from magnets, magnet_types
  3276.         where magnets.bucketid = $bucketid and
  3277.               magnet_types.id = magnets.mtid and
  3278.               magnet_types.mtype = '$type' order by magnets.val;" );
  3279.  
  3280.     $h->execute;
  3281.     while ( my $row = $h->fetchrow_arrayref ) {
  3282.         push @result, ($row->[0]);
  3283.     }
  3284.     $h->finish;
  3285.  
  3286.     return @result;
  3287. }
  3288.  
  3289. # ---------------------------------------------------------------------------------------------
  3290. #
  3291. # create_magnet
  3292. #
  3293. # Make a new magnet
  3294. #
  3295. # $session         A valid session key returned by a call to get_session_key
  3296. # $bucket          The bucket the magnet belongs in
  3297. # $type            The magnet type (e.g. from, to or subject)
  3298. # $text            The text of the magnet
  3299. #
  3300. # ---------------------------------------------------------------------------------------------
  3301. sub create_magnet
  3302. {
  3303.     my ( $self, $session, $bucket, $type, $text ) = @_;
  3304.  
  3305.     my $userid = $self->valid_session_key__( $session );
  3306.     return undef if ( !defined( $userid ) );
  3307.  
  3308.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  3309.     my $result = $self->{db__}->selectrow_arrayref("select magnet_types.id from magnet_types
  3310.                                                         where magnet_types.mtype = '$type';" );
  3311.  
  3312.     my $mtid = $result->[0];
  3313.  
  3314.     $self->{db__}->do( "insert into magnets ( bucketid, mtid, val )
  3315.                                      values ( $bucketid, $mtid, '$text' );" );
  3316. }
  3317.  
  3318. # ---------------------------------------------------------------------------------------------
  3319. #
  3320. # get_magnet_types
  3321. #
  3322. # Get a hash mapping magnet types (e.g. from) to magnet names (e.g. From);
  3323. #
  3324. # $session     A valid session key returned by a call to get_session_key
  3325. #
  3326. # ---------------------------------------------------------------------------------------------
  3327. sub get_magnet_types
  3328. {
  3329.     my ( $self, $session ) = @_;
  3330.  
  3331.     my $userid = $self->valid_session_key__( $session );
  3332.     return undef if ( !defined( $userid ) );
  3333.  
  3334.     my %result;
  3335.  
  3336.     my $h = $self->{db__}->prepare( "select magnet_types.mtype, magnet_types.header from magnet_types order by mtype;" );
  3337.  
  3338.     $h->execute;
  3339.     while ( my $row = $h->fetchrow_arrayref ) {
  3340.         $result{$row->[0]} = $row->[1];
  3341.     }
  3342.     $h->finish;
  3343.  
  3344.     return %result;
  3345. }
  3346.  
  3347. # ---------------------------------------------------------------------------------------------
  3348. #
  3349. # delete_magnet
  3350. #
  3351. # Remove a new magnet
  3352. #
  3353. # $session         A valid session key returned by a call to get_session_key
  3354. # $bucket          The bucket the magnet belongs in
  3355. # $type            The magnet type (e.g. from, to or subject)
  3356. # $text            The text of the magnet
  3357. #
  3358. # ---------------------------------------------------------------------------------------------
  3359. sub delete_magnet
  3360. {
  3361.     my ( $self, $session, $bucket, $type, $text ) = @_;
  3362.  
  3363.     my $userid = $self->valid_session_key__( $session );
  3364.     return undef if ( !defined( $userid ) );
  3365.  
  3366.     my $bucketid = $self->{db_bucketid__}{$userid}{$bucket}{id};
  3367.     my $result = $self->{db__}->selectrow_arrayref("select magnet_types.id from magnet_types
  3368.                                                         where magnet_types.mtype = '$type';" );
  3369.  
  3370.     my $mtid = $result->[0];
  3371.  
  3372.     $self->{db__}->do( "delete from magnets
  3373.                             where magnets.bucketid = $bucketid and
  3374.                                   magnets.mtid = $mtid and
  3375.                                   magnets.val  = '$text';" );
  3376. }
  3377.  
  3378. # ---------------------------------------------------------------------------------------------
  3379. #
  3380. # get_stopword_list
  3381. #
  3382. # Gets the complete list of stop words
  3383. #
  3384. # $session     A valid session key returned by a call to get_session_key
  3385. #
  3386. # ---------------------------------------------------------------------------------------------
  3387. sub get_stopword_list
  3388. {
  3389.     my ( $self, $session ) = @_;
  3390.  
  3391.     my $userid = $self->valid_session_key__( $session );
  3392.     return undef if ( !defined( $userid ) );
  3393.  
  3394.     return $self->{parser__}->{mangle__}->stopwords();
  3395. }
  3396.  
  3397. # ---------------------------------------------------------------------------------------------
  3398. #
  3399. # magnet_count
  3400. #
  3401. # Gets the number of magnets that are defined
  3402. #
  3403. # $session     A valid session key returned by a call to get_session_key
  3404. #
  3405. # ---------------------------------------------------------------------------------------------
  3406. sub magnet_count
  3407. {
  3408.     my ( $self, $session ) = @_;
  3409.  
  3410.     my $userid = $self->valid_session_key__( $session );
  3411.     return undef if ( !defined( $userid ) );
  3412.  
  3413.     my $result = $self->{db__}->selectrow_arrayref( "select count(*) from magnets, buckets
  3414.         where buckets.userid = $userid and
  3415.               magnets.bucketid = buckets.id;" );
  3416.  
  3417.     if ( defined( $result ) ) {
  3418.         return $result->[0];
  3419.     } else {
  3420.         return 0;
  3421.     }
  3422. }
  3423.  
  3424. # ---------------------------------------------------------------------------------------------
  3425. #
  3426. # add_stopword, remove_stopword
  3427. #
  3428. # Adds or removes a stop word
  3429. #
  3430. # $session     A valid session key returned by a call to get_session_key
  3431. # $stopword    The word to add or remove
  3432. #
  3433. # Return 0 for a bad stop word, and 1 otherwise
  3434. #
  3435. # ---------------------------------------------------------------------------------------------
  3436. sub add_stopword
  3437. {
  3438.     my ( $self, $session, $stopword ) = @_;
  3439.  
  3440.     my $userid = $self->valid_session_key__( $session );
  3441.     return undef if ( !defined( $userid ) );
  3442.  
  3443.     # Pass language parameter to add_stopword()
  3444.  
  3445.     return $self->{parser__}->{mangle__}->add_stopword( $stopword, $self->module_config_( 'html', 'language' ) );
  3446. }
  3447.  
  3448. sub remove_stopword
  3449. {
  3450.     my ( $self, $session, $stopword ) = @_;
  3451.  
  3452.     my $userid = $self->valid_session_key__( $session );
  3453.     return undef if ( !defined( $userid ) );
  3454.  
  3455.     # Pass language parameter to remove_stopword()
  3456.  
  3457.     return $self->{parser__}->{mangle__}->remove_stopword( $stopword, $self->module_config_( 'html', 'language' ) );
  3458. }
  3459.  
  3460. # ---------------------------------------------------------------------------------------------
  3461. # ---------------------------------------------------------------------------------------------
  3462. #       _____   _____   _____  _______ _____        _______     _______  _____  _____
  3463. #      |_____] |     | |_____] |______   |   |      |______     |_____| |_____]   |
  3464. #      |       |_____| |       |       __|__ |_____ |______     |     | |       __|__
  3465. #
  3466. # ---------------------------------------------------------------------------------------------
  3467. # ---------------------------------------------------------------------------------------------
  3468.  
  3469. # GETTERS/SETTERS
  3470.  
  3471. sub wordscores
  3472. {
  3473.     my ( $self, $value ) = @_;
  3474.  
  3475.     $self->{wordscores__} = $value if (defined $value);
  3476.     return $self->{wordscores__};
  3477. }
  3478.  
  3479. sub scores
  3480. {
  3481.     my ( $self, $value ) = @_;
  3482.  
  3483.     $self->{scores__} = $value if (defined $value);
  3484.     return $self->{scores__};
  3485. }
  3486.  
  3487. sub wmformat
  3488. {
  3489.     my ( $self, $value ) = @_;
  3490.  
  3491.     $self->{wmformat__} = $value if (defined $value);
  3492.     return $self->{wmformat__};
  3493. }
  3494.  
  3495. 1;
  3496.  
  3497.